SUBROUTINE W3FI52(IDENT,CNST,IER) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: W3FI52 COMPUTES SCALING CONSTANTS USED BY GRDPRT C AUTHOR: STACKPOLE,J. ORG: W342 DATE: 85-12-03 C AUTHOR: JONES,R.E. C C ABSTRACT: 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 80-06-15 J. STACKPOLE C 85-12-03 R.E.JONES MADE SUBROUTINE IN GENOUT INTO THIS SUBR. C 89-07-07 R.E.JONES CONVERT TO MICROSOFT FORTRAN 4.10 C 90-02-03 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN C C USAGE: CALL W3FI52(IDENT,CNST,IER) C C INPUT VARIABLES: C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES C ------ --------- ----------------------------------------------- C IDENT ARG LIST FIRST 5 ID'S IN OFFICE NOTE 84 FORMAT C C OUTPUT VARIABLES: C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES C ------ --------- ----------------------------------------------- C CNST ARG LIST 4 CONSTANT'S USED BY GRDPRT,W3FP05, OR W3FP03 C IER ARG LIST 0 = NORMAL RETURN C 1 = ID'S IN IDENT ARE NOT IN O.N. 84 FORMAT C C SUBPROGRAMS CALLED: C NAMES LIBRARY C ------------------------------------------------------- -------- C W3FI33 W3LIB C C ATTRIBUTES: C LANGUAGE: MICROSOFT FORTRAN 4.10 OPTIMIZING COMPILER C MACHINE: IBM PC, AT, PS/2, 386, CLONES. C C$$$ 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