home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / FORTRAN / D2SOURCE.ZIP / PSST2.FOR < prev    next >
Encoding:
Text File  |  1986-02-07  |  3.0 KB  |  92 lines
  1. C  PASQUILL STABILITY CATEGORY SELECTOR/ TURNER/CGW
  2.       SUBROUTINE STAB (U,IS,IL,IM,ID)
  3.       COMMON SDM(68),SLA,SLO,CC,CH,AE,SD2(21),IHR,SD3(15)
  4.       CHARACTER*1 ISTA,MTC
  5.       CHARACTER*20 ADH
  6.       CHARACTER*3 IMO,IMOT
  7.       DIMENSION AC(4),IST(7,8),ISTA(6),IDC(12),SE(4)
  8.       DIMENSION IMOT(12),SLAT(10),SLOT(10)
  9.       DATA AC/15.,35.,60.,90./
  10.       DATA ISTA/'A','B','C','D','E','F'/
  11.       DATA IST/6,6,4,3,2,1,1,6,6,4,3,2,2,1,6,5,4,4,3,2,1,6,5,4,4,3,2,2,
  12.      15,4,4,4,3,3,2,5,4,4,4,4,3,3,4,4,4,4,4,3,3,4,4,4,4,4,4,3/
  13.       DATA IDC/0,0,3,3,4,4,5,5,5,6,6,7/
  14.       DATA IMOT /'JAN','FEB','MAR','APR','MAY','JUN','JUL','AUG',
  15.      $            'SEP','OCT','NOV','DEC'/
  16.       DATA VE /79.6729/
  17.       DATA SE /92.78,93.64,89.83,89./
  18.       DATA HY /182.62/
  19.       DATA PH /1.570796/
  20.       DATA PI /3.141593/
  21.       DATA P2 /6.283185/
  22.       DATA RD /57.2958/
  23.       DATA SLAT/33.7,40.,39.3,16.7,38.,40.,34.,38.,40.,46./
  24.       DATA SLOT/86.1,113.,76.,169.5,84.,87.5,92.,2*105.,120./
  25.       IF (IL.LT.11) GO TO 30
  26. C     32. STATION LATITUDE AND LONGITUDE
  27.  10   CALL DEF(32,IRT)
  28.       IF (IRT.EQ.0) READ(*,*) SLA,SLO
  29.       GO TO 40
  30.   30  SLA=SLAT(IL)
  31.       SLO=SLOT(IL)
  32.   40  A=SLA/RD
  33. C     33. MONTH,DAY,HOUR (JAN,01,1200)
  34.       CALL DEF(33,IRT)
  35.       IF (IRT.EQ.1) GO TO 80
  36.       READ(*,'(A3,1X,BN,A20)') IMO,ADH
  37.       READ(ADH,'(BN,I2,1X,I4)') ID,IHR
  38.   60  DO 70 IM=1,12
  39.       IF(IMO.EQ.IMOT(IM)) GO TO 80
  40.   70  CONTINUE
  41.       GO TO 40  
  42. C     34. CLOUD COVER (1/10),CLOUD HEIGHT (FT)  
  43.   80  CALL DEF (34,IRT) 
  44.       IF (IRT.EQ.0) READ(*,*) CC,CH 
  45.       HRC=IHR/100.  
  46.       HRS=(HRC-INT(HRC))/0.6+INT(HRC)   
  47.       IF (IM.NE.0) GO TO 100
  48. C     35. SUN ELEVATION ANGLE
  49.       CALL DEF(35,RT)   
  50.       IF (IRT.EQ.0) READ(*,*) AE
  51.       GO TO 130 
  52.  100  DJ=(IM-1)*31-IDC(IM)+ID   
  53.       DV=DJ-VE  
  54.       IF (DV.LT.0.) DV=DV+365.  
  55.       DT=DV 
  56.       DO 110 I=1,4  
  57.       IF (DT.LT.SE(I)) GO TO 120
  58.       DT=DT-SE(I)   
  59.  110  CONTINUE  
  60.  120  DL=SIN(PH*((I-1)+DT/SE(I)))*.4091 
  61.       EQ=(10.*SIN((DV+89.)/HY*P2)+7.75*SIN((DV+78)/HY*PI))/60.  
  62.       HDL=ACOS(-.014538/COS(A)/COS(DL)-(TAN(A)*TAN(DL)))/.2618  
  63.       TC=12.+EQ+(SLO/15.-AINT(SLO/15.)) 
  64.       ISR=(((TC-HDL)-AINT(TC-HDL))*.6+AINT(TC-HDL))*100.
  65.       ISS=(((TC+HDL)-AINT(TC+HDL))*.6+AINT(TC+HDL))*100.
  66.       AE=ASIN(SIN(A)*SIN(DL)+COS(A)*COS(DL)*COS((HRS-TC)*.2618))*RD 
  67.  130  I=0   
  68.       IF (CC.EQ.10.AND.CH.LT.7000.) GO TO 190   
  69.       IF (HRS.GT.(13.-HDL).AND.HRS.LT.(11.+HDL)) GO TO 140  
  70.       I=-2  
  71.       IF (CC.GT.4.) I=-1
  72.       GO TO 190
  73.  140  DO 150 I=1,4
  74.       IF (AE.LT.AC(I)) GO TO 160
  75.  150  CONTINUE
  76.       I=4
  77.  160  IF (CC.LT.6.OR.CH.GT.16000.) GO TO 190
  78.       IF (CC.GT.9.OR.CH.GE.7000.) GO TO 170
  79.       I=I-2
  80.       GO TO 180
  81.  170  I=I-1
  82.  180  IF (I.LT.1) I=1
  83.  190  I=I+3
  84.       J=U+1.
  85.       IF (U.GT.6.) J=8
  86.       IS=IST(I,J)
  87.       MTC=ISTA(IS)
  88.       WRITE(*,200) ISR,ISS,AE,MTC
  89.  200  FORMAT(' SR',I4,3X,' SS',I5,3X,' AE',F6.2,3X,' STAB ',A1)
  90.       RETURN
  91.       END
  92.