w3fi52.f

Go to the documentation of this file.

C> @file
C> @brief Computes scaling constants used by grdprt().
C> @author John Stackpole @date 1980-06-15
 
C> Computes the four scaling constants used by grdprt(), w3fp03(),
C> or w3fp05() from the 1st 5 identifier words in office note 84 format.
C>
C> Program history log:
C> - John Stackpole 1980-06-15
C> - Ralph Jones 1985-12-03 Made subroutine in genout into this subr.
C> - Ralph Jones 1989-07-07 Convert to microsoft fortran 4.10
C> - Ralph Jones 1990-02-03 Convert to cray cft77 fortran
C>
C> @param[in] IDENT First 5 id's in office note 84 format.
C> @param[out] CNST 4 constant's used by grdprtO(), w3fp05(), or w3fp03()
C> @param[out] IER
C> - 0 = normal return.
C> - 1 = ID'S IN IDENT ARE NOT IN O.N. 84 FORMAT
C>
C> @author John Stackpole @date 1980-06-15
      SUBROUTINE w3fi52(IDENT,CNST,IER)
C
CC       SET DEFAULT VALUES FOR NMC FIELDS  GRIDPRINTING
C
      REAL      CNST(4)
C
      INTEGER   IDENT(4)
      INTEGER   LABUNP(27)
      INTEGER   Q
C
C     UPACK 8 OFFICE NOTE 84 ID'S INTO 27 PARTS
C
      CALL w3fi33(ident,labunp)
C
      itypeq = labunp(1)
      q      = itypeq
      itypes = labunp(2)
      itypec = labunp(5)
      isc    = labunp(6)
      ier    = 0
      xlvl   = itypec
      IF (isc) 10,30,20
C
   10 CONTINUE
        isc = -isc
C
C     DIVIDE BY WHOLE NUMBER RATHER THAN MULTIPLY BY FRACTION TO
C     TO AVOID ROUND OF ERROR
C
        xlvl = xlvl / (10.**isc)
        GO TO 30
C
   20 CONTINUE
        xlvl = xlvl * (10.**isc)
C
   30 CONTINUE
        ilvl = xlvl
        IF (q.NE.1.AND.q.NE.2)  GO TO 40
C
C***  GEOPOTENTIAL METERS ............
C
      cnst(3) = 60.
      IF  (ilvl .LT. 500)  cnst(3) = 120.
      IF  ((itypes .EQ. 129) .OR. (itypes .EQ. 130)) cnst(3) = 500.
      cnst(1) = 0.
      cnst(2) = 1.
      cnst(4) = 0.
      IF  (cnst(3) .EQ. 500.)  cnst(4) = 2.
         RETURN
C
   40 CONTINUE
        IF (q.NE.8) GO TO 50
C
C***  PRESSURE, MILLIBARS ...............
C
      cnst(1) = 0.
      cnst(2) = 1.
      cnst(3) = 4.
      cnst(4) = 0.
C
C***   IF SFC OR TROPOPAUSE PRESSURE ..
C
      IF  ((itypes .EQ. 129) .OR. (itypes .EQ. 130))  cnst(3) = 25.
         RETURN
C
   50 CONTINUE
      DO 60 i = 16,21
         IF (q.EQ.i)  GO TO 70
   60 CONTINUE
        GO TO 80
C
   70 CONTINUE
C
C*** TEMPERATURES (DEG K) CONVERT TO DEG C, EXCEPT FOR POTENTIAL TEMP.
C
      cnst(1) = -273.15
      cnst(2) = 1.
      cnst(3) = 5.
      cnst(4) = 0.
      IF  (itypeq .EQ. 19)  cnst(1) = 0.
         RETURN
C
   80 CONTINUE
        IF (q.NE.40)  GO TO 90
C
C***  VERTICAL VELOCITY (MB/SEC) TO MICROBARS/SEC
C***  SIGN CHANGED SUCH THAT POSITIVE VALUES INDICATE UPWARD MOTION.
C
      cnst(1) =  0.
      cnst(2) = -1.e3
      cnst(3) = 2.
      cnst(4) = 0.
         RETURN
C
   90 CONTINUE
        IF (q.NE.41)  GO TO 100
C
C***  NET VERTICAL DISPLACEMENT  ...  MILLIBARS
C
      cnst(1) =  0.
      cnst(2) =  1.
      cnst(3) = 10.
      cnst(4) =  0.
         RETURN
C
  100 CONTINUE
      DO 110 i = 48,51
        IF (q.EQ.i)  GO TO 120
  110 CONTINUE
         GO TO 130
C
  120 CONTINUE
C
C***   WIND SPEEDS   M/SEC
C
      cnst(1) = 0.
      cnst(2) = 1.
      cnst(3) = 10.
      cnst(4) = 0.
         RETURN
C
  130 CONTINUE
        IF (q.NE.52)  GO TO 140
C
C***  VERTICAL SPEED SHEAR(/ SEC)...   TO BE CONVERTED TO KNOTS/1000 FT
C
      cnst(1) = 0.
      cnst(2) = 592.086
      cnst(3) = 2.
      cnst(4) = 0.
         RETURN
C
  140 CONTINUE
        IF (q.NE.53.AND.q.NE.54)  GO TO 150
C
C***  DIVERGENT U AND V COMPONENTS   M/SEC
C
      cnst(1) = 0.
      cnst(2) = 1.
      cnst(3) = 2.
      cnst(4) = 0.
         RETURN
C
  150 CONTINUE
        IF (q.NE.72.AND.q.NE.73)  GO TO 160
C
C***  VORTICITY (APPROX 10**-5)  TIMES 10**6 /SEC
C
      cnst(1) = 0.
      cnst(2) = 1.e6
      cnst(3) = 40.
      cnst(4) = 0.
         RETURN
C
  160 CONTINUE
        IF (q.NE.74)  GO TO 170
C
C***  DIVERGENCE    (/SEC)       TIMES 10**6
C
      cnst(1) = 0.
      cnst(2) = 1.e6
      cnst(3) = 20.
      cnst(4) = 0.
         RETURN
C
  170 CONTINUE
        IF (q.NE.80.AND.q.NE.81)  GO TO 180
C
C***  STREAM FUNCTION OR VELOCITY POTENTIAL (M*M/SEC) CONVERTED TO M.
C***  CONVERT TO METERS.    (M*M/SEC  * FOG)
C
      cnst(1) = 0.
      cnst(2) = 1.03125e-4 / 9.8
      cnst(3) = 60.
      cnst(4) = 0.
      IF ((ilvl.LT.500) .AND. (itypec .EQ. 0)) cnst(3) = 120.
         RETURN
C
  180 CONTINUE
        IF (q.NE.88)  GO TO 190
C
C***  RELATIVE HUMIDITY  ...  PERCENT
C
      cnst(1) = 0.
      cnst(2) = 1.
      cnst(3) = 10.
      cnst(4) = 0.
         RETURN
C
  190 CONTINUE
        IF (q.NE.89)  GO TO 200
C
C***  PRECIPITABLE WATER (KG/M*M) OR .1 GRAM/CM*CM OR MILLIMETERS/CM*CM
C***   CHANGE TO CENTI-INCHES/CM*CM
C
      cnst(1) = 0.
      cnst(2) = 3.937
      cnst(3) = 5.
      cnst(4) = 0.
         RETURN
C
  200 CONTINUE
        IF (q.NE.90)  GO TO 210
C
C***  ACCUMULATED PRECIPITATION (METERS)   TO CENTI-INCHES, AT 1/2 IN.
C
      cnst(1) = 0.
      cnst(2) = 3937.
      cnst(3) = 50.
      cnst(4) = 0.
         RETURN
C
  210 CONTINUE
        IF (q.NE.91.AND.q.NE.92)  GO TO 220
C
C***  PROBABILITY  ...  PERCENT
C
      cnst(1) = 0.
      cnst(2) = 1.
      cnst(3) = 10.
      cnst(4) = 0.
         RETURN
C
  220 CONTINUE
        IF (q.NE.93)  GO TO  230
C
C***  SNOW DEPTH (METERS)    TO INCHES, AT INTERVALS OF 6 INCHES
C
      cnst(1) = 0.
      cnst(2) = 39.37
      cnst(3) = 6.
      cnst(4) = 0.
         RETURN
C
  230 CONTINUE
        IF (q.NE.112)  GO TO 240
C
C***  LIFTED INDEX  ..(DEG K)   TO DEG C.
C
      cnst(1) = -273.15
      cnst(2) = 1.
      cnst(3) = 2.
      cnst(4) = 0.
         RETURN
C
  240 CONTINUE
        IF (q.NE.120.AND.q.NE.121)  GO TO 250
C
C***  WAVE COMPONENT OF GEOPOTENTIAL   (GEOP M)
C
      cnst(1) = 0.
      cnst(2) = 1.
      cnst(3) = 10.
      cnst(4) = 0.
         RETURN
C
  250 CONTINUE
        IF (q.NE.160)  GO TO 260
C
C***  DRAG COEFFICIENT  DIMENSIONLESS       TIMES 10**5
C
      cnst(1) = 0.
      cnst(2) = 1.e5
      cnst(3) = 100.
      cnst(4) = 0.
         RETURN
C
  260 CONTINUE
        IF (q.NE.161)  GO TO 270
C
C***  LAND/SEA   DIMENSIONLESS
C
      cnst(1) = 0.
      cnst(2) = 1.
      cnst(3) = 1.
      cnst(4) = .5
       RETURN
C
  270 CONTINUE
        IF (q.NE.169)  GO TO 280
C
C           ALBIDO * 100.  (DIMENSIONLESS)
C
            cnst(1) = 0.
            cnst(2) = 100.
            cnst(3) = 5.
            cnst(4) = 0.
            RETURN
C
  280 CONTINUE
      IF  (itypeq .EQ. 384)  GO TO 290
      IF  ((itypeq .GE. 385) .AND. (itypeq .LE. 387)) GO TO 300
C
C*** NONE OF THE ABOVE ....
C
        ier = 1
        RETURN
C
C***  OCEAN WATER TEMPERATURE  (DEGREES K)
C
  290 CONTINUE
        cnst(1) = 0.
        cnst(2) = 1.
        cnst(3) = 5.
        cnst(4) = 0.
        RETURN
C
C***  HEIGHT OF WIND DRIVEN OCEAN WAVES, SEA SWELLS, OR COMBINATION
C
  300 CONTINUE
        cnst(1) = 0.
        cnst(2) = 1.
        cnst(3) = 2.
        cnst(4) = 0.
      RETURN
      END