C$$$ MAIN PROGRAM DOCUMENTATION BLOCK 00000100 C 00000200 C MAIN PROGRAM: SSTSNOV PRODUCE SST AND SNO INPUT FOR RDAS/RAFS 00000300 C PRGMMR: MITCHELL ORG: NMC22 DATE: 92-11-24 00000400 C 00000500 C ABSTRACT: PRODUCE SST AND SNO INPUTS FOR RDAS/RAFS 00000600 C - READ SST AND WEEKLY SNO FIELDS FROM THE VSAM GES FILE 00000700 C - ALSO READ THE DAILY USAF SNO/ICE ANAL SENT FROM AFGWC 00000800 C ....VIA SPN NET TO NESDIS CEMSCS (DASD SHARED DISK) 00000900 C - PACK USAF SNO/ICE ANAL INTO O.N. 84 FORMAT 00001000 C - WRITE ALL THREE FIELDS TO A SEQUENTIAL FILE FOR 00001100 C ....USE BY REGIONAL RUNS ON CRAY Y-MP 00001200 C 00001300 C PROGRAM HISTORY LOG: 00001400 C 85-10-02 MARGULIES 00001500 C 87-10-20 CAVANAUGH ADDED SNOW COVER FIELD TO OUTPUT 00001600 C 87-12-16 CAVANAUGH CORRECTED SIZE ERROR FROM 3608 TO 3973 00001700 C ON SNC FIELD. 00001800 C 88-01-15 CAVANAUGH REMOVED UNUSED DATA SST, WTP AND SND FILES 00001900 C FROM OUTPUT. 00002000 C 88-10-28 R.E.JONES CHANGE FORTXDAM-W3FK00 I/O TO VSAM-W3FK40 00002100 C I/O. ADD MORE ERROR MESSAGES AND STOPS 00002200 C 92-11-17 K. MITCHELL ADD READ, PACKING, AND WRITE OF USAF 00002300 C SNOW-ICE ANAL FROM AFGWC 00002400 C 00002500 C USAGE: 00002600 C INPUT FILES: 00002700 C GES - WTEMP AND SNO FIELDS 00002800 C FT20F001 - COM.PSNSNIRT.SNODEPH.NHMAMAP A NESDIS FILE ON 00002900 C CEMSCS DASD SHARED DISK 00003000 C OUTPUT FILES: 00003100 C FT13F001 - NMC.PROD.(T00Z OR T12Z).SSTSNO ON A 3380 DISK 00003200 C FT06F001 - PRINT MESSAAGES 00003300 C 00003400 C SUBPROGRAMS CALLED: 00003500 C LIBRARY: 00003600 C W3LIB - W3FK40, W3FK41, W3FK43, W3FK49, W3FQ02, W3FS11, 00003700 C W3FI32, W3AI00, W3TAGB, W3TAGE, W3LOG 00003800 C 00003900 C EXIT STATES: 00004000 C COND = 3 - READ ERROR ON UNIT 20 (NONFATAL USAF SNO ERROR) 00004100 C = 4 - EOF ERROR ON UNIT 20 (NONFATAL USAF SNO ERROR) 00004200 C = 5 - W3FK40 OPEN ERROR ON GES FILE 00004300 C = 6 - W3FK41 READ ID TABLE ERROR ON GES FILE 00004400 C = 7 - W3FK43 READ ERROR ON GES FILE 00004500 C 00004600 C REMARKS: ONLY WTMP AND SNC FIELDS FROM GES FILE ARE ESSENTIAL 00004700 C AS RGNL RUNS WILL RESORT TO THESE IF USAF ANAL ABSENT 00004800 C 00004900 C ATTRIBUTES: 00005000 C LANGUAGE: FORTRAN 77 (COMPILED/EXECUTED WITH PROC JS7XCLG) 00005100 C MACHINE: NAS 9000 00005200 C 00005300 C$$$ 00005400 C 00005500 PARAMETER ( IIAF=512, JJAF=512, NPK=12+IIAF*JJAF/2) 00005600 C 00005700 INTEGER*4 IDSTNO(2)/ZE2E2E3E2, ZD5D6C2F2 / 00005800 INTEGER*4 IDWTP(5) /Z18008100, Z00000000, Z0FF00000, 00005900 * Z00000000, Z00000021 / 00006000 INTEGER*4 IDSNC(5) /Z05D08100, Z00000000, Z0FF00000, 00006100 * Z00000000, Z00000051 / 00006200 INTEGER*4 IDTBL(1539) 00006300 INTEGER*4 IWTP(4175) 00006400 INTEGER*4 ISNC(3973) 00006500 INTEGER*4 ITIME(4) 00006600 C 00006700 INTEGER*4 LABL84(27) 00006800 INTEGER*4 LBLF(12) 00006900 C 00007000 INTEGER*2 IDATA(IIAF) 00007100 C 00007200 REAL*4 SNODEP(IIAF,JJAF) 00007300 REAL*4 PACKED(NPK) 00007400 C 00007500 REAL*8 GES /'GES '/ 00007600 C 00007700 CHARACTER*1 KDAT1(8),KDAT2(8),INUM(10) 00007800 CHARACTER*2 LLMO,NMO(12) 00007900 C 00008000 COMMON /VSAMER/ INDEX(5) 00008100 C 00008200 EQUIVALENCE (IDATA(1),KDAT1(1)) 00008300 EQUIVALENCE (IDATA(5),KDAT2(1)) 00008400 EQUIVALENCE (IDATA(9),JULHR) 00008500 EQUIVALENCE (LLMO,KDAT2(4)) 00008600 C 00008700 EQUIVALENCE (SNODEP,PACKED) 00008800 C 00008900 DATA LABL84/ 93, 129, 0, 0, 0, 0, 0, 00009000 * 255, 0, 0, 0, 0, 0, 0, 00009100 A 0, 0, 88, 0, 0, 0, 92, 00009200 B 12, 2, 0, 15, 59, 262144/ 00009300 C 00009400 C....... ABBREVIATIONS OF MONTHS..FROM NESDIS...OCT92 00009500 DATA NMO/'JA','FE','MR','AP','MY','JN','JL','AU','SE','OC','NO', 00009600 1 'DE'/ 00009700 C 00009800 DATA INUM/'1','2','3','4','5','6','7','8','9','0'/ 00009900 C 00010000 CALL W3LOG('$S92329.78','SSTSNOV ') 00010100 CALL W3TAGB('SSTSNOV ',0092,0329,0078,'NMC22 ') 00010200 C 00010300 PRINT 15 00010400 15 FORMAT( '1', 25X, 'PGM = SSTSNOV COMPILE DATE 92-11-17' ) 00010500 C 00010600 C.... BEGIN HERE .... 00010700 C 00010800 C$ OPEN FILE GES 00010900 C 00011000 CALL W3FK40 ( GES, IDUMMY, 255 ) 00011100 IF (INDEX(1).EQ.0) GO TO 100 00011200 PRINT 50 , GES, INDEX(1), INDEX(2) 00011300 CALL W3LOG('$E',5,' W3FK40 OPEN ERROR ON FILE GES:') 00011400 CALL W3TAGE('SSTSNOV ') 00011500 50 FORMAT ( ' W3FK40 OPEN ERROR ON FILE = ',A8,', ERR = ',2Z9) 00011600 STOP 5 00011700 C 00011800 C$ READ ID TABLE OF GES FILE 00011900 C 00012000 100 CONTINUE 00012100 CALL W3FK41 ( GES, IDTBL, 255 ) 00012200 IF (INDEX(1).EQ.0) GO TO 200 00012300 PRINT 150 , GES, INDEX 00012400 150 FORMAT ( ' W3FK41 READ ERROR ON FILE = ',A8,', ERR = ',5Z9) 00012500 CALL W3LOG('$E',6,' W3FK41 READ ERROR ON FILE GES:') 00012600 CALL W3TAGE('SSTSNOV ') 00012700 STOP 6 00012800 C 00012900 C$ READ WTP 00013000 C 00013100 200 CONTINUE 00013200 CALL W3FK43 ( GES, IDTBL, IDWTP, IWTP, 255, 4175, LERR ) 00013300 C 00013400 C$ READ SNC RECORD 00013500 C 00013600 CALL W3FK43 ( GES, IDTBL, IDSNC, ISNC, 255, 3973, KKERR ) 00013700 C 00013800 C CLOSE GES FILE 00013900 CALL W3FK49 (GES) 00014000 C 00014100 C$ CHECK FOR ERROR 00014200 C 00014300 MERR = LERR + KKERR 00014400 IF ( MERR .EQ. 0 ) GO TO 650 00014500 PRINT 625 00014600 IF (LERR.NE.0 ) PRINT 629, LERR 00014700 IF (KKERR.NE.0 ) PRINT 630, KKERR 00014800 625 FORMAT ( 1X, 'ERROR IN W3FK43 READ',/) 00014900 629 FORMAT ( 1X, 'ERROR IN WTP ', I4 ) 00015000 630 FORMAT ( 1X, 'ERROR IN SNC ', I4 ) 00015100 C 00015200 CALL W3LOG('$E',7,' W3FK43 READ ERROR ON FILE GES:') 00015300 CALL W3TAGE('SSTSNOV ') 00015400 STOP 7 00015500 C 00015600 650 CONTINUE 00015700 C 00015800 C$ WRITE TO NEW FILE 00015900 C 00016000 IDTBL(1) = IDSTNO(1) 00016100 IDTBL(2) = IDSTNO(2) 00016200 C 00016300 WRITE( 13 ) (IDTBL(I),I=1,8) 00016400 WRITE( 13 ) IWTP 00016500 WRITE( 13 ) ISNC 00016600 C 00016700 C$ PRINT DATE OF FIELDS 00016800 C 00016900 CALL W3FS11( IWTP(7), IWTPYR, IWTPMO, IWTPDA, IWTPHR, 1 ) 00017000 CALL W3FS11( ISNC(7), ISNCYR, ISNCMO, ISNCDA, ISNCHR, 1 ) 00017100 C 00017200 PRINT 685, IWTPYR, IWTPMO, IWTPDA, IWTPHR, 00017300 * ISNCYR, ISNCMO, ISNCDA, ISNCHR 00017400 685 FORMAT ( 1X, 'DATE OF WTP ',I2,'/',I2,'/',I2, ' AT ',I2,'Z' 00017500 * / 1X, 'DATE OF SNC ',I2,'/',I2,'/',I2, ' AT ',I2,'Z') 00017600 C 00017700 C*******************REMAINDER OF CODE******************************** 00017800 C 00017900 C PROCESS USAF SNOW/ICE ANAL (OBTAINED FROM AFGWC VIA SPN) 00018000 C 00018100 C USAF SNOW/ICE ANAL IS DAILY AND HIGH RES (45 KM) 00018200 C BUT RDAS/RAFS RGNL NETWORK WILL RUN WITHOUT IT 00018300 C USING ISNC FIELD (WEEKLY, 190 KM) WRITTEN ABOVE AS BACK-UP 00018400 C 00018500 C******************************************************************** 00018600 C 00018700 IAF = IIAF 00018800 JAF = JJAF 00018900 JAFP1 = JJAF + 1 00019000 C 00019100 REWIND 20 00019200 C 00019300 C READ TWO HEADER RECORDS, WHICH ARE DUPLICATES OF EACH OTHER 00019400 C EACH HEADER CONTAINS SAME ID INFO AS FOLLOWS IN FIRST 20 BYTES 00019500 C 8-BYTE EBCDIC TITLE: 8H(NHSNOW) BYTES 1-8 00019600 C 8-BYTE EBCDIC DATE : 8H DDMMYY BYTES 9-16 00019700 C 4-BYTE I*4 AFGWC JULHR: BYTES 17-20 00019800 C 00019900 READ (20,ERR=980,END=990) IDATA 00020000 READ (20,ERR=980,END=990) IDATA 00020100 C 00020200 C CONVERT AFGWC ACCUMULATED JULHR SINCE DEC 69 TO CURRENT GMT HOUR 00020300 C 00020400 IHR = MOD(JULHR,24) 00020500 C 00020600 PRINT 801, KDAT1, KDAT2, IHR, JULHR 00020700 801 FORMAT(1H ,' USAF SNOW/ICE -- TITLE/DATE/GMTHR/AFJULHR: ', 00020800 * 8A1,8A1,I4,I10) 00020900 C 00021000 C CONVERT EBCDIC LABEL (KDAT2) OF DAY,MONTH,YEAR TO NUMERIC VALUES 00021100 C 00021200 DO 810 J=1,10 00021300 JTENS = J 00021400 IF (KDAT2(2).EQ.INUM(J)) GO TO 812 00021500 810 CONTINUE 00021600 812 IF (JTENS.EQ.10) JTENS=0 00021700 DO 820 J=1,10 00021800 JONES = J 00021900 IF (KDAT2(3).EQ.INUM(J)) GO TO 814 00022000 820 CONTINUE 00022100 814 IF (JONES.EQ.10) JONES=0 00022200 IDAY = JTENS * 10 + JONES 00022300 DO 910 J=1,10 00022400 JTENS = J 00022500 IF (KDAT2(6).EQ.INUM(J)) GO TO 912 00022600 910 CONTINUE 00022700 912 IF (JTENS.EQ.10) JTENS=0 00022800 DO 920 J=1,10 00022900 JONES = J 00023000 IF (KDAT2(7).EQ.INUM(J)) GO TO 914 00023100 920 CONTINUE 00023200 914 IF (JONES.EQ.10) JONES=0 00023300 IYR = JTENS * 10 + JONES 00023400 DO 922 J=1,12 00023500 MONTH = J 00023600 IF (LLMO.EQ.NMO(J)) GO TO 924 00023700 922 CONTINUE 00023800 924 CONTINUE 00023900 C 00024000 C PREPARE DATE PART OF ON84 LABEL FOR AFGWC SNODEPTH ANALYSIS 00024100 C 00024200 LABL84(21) = IYR 00024300 LABL84(22) = MONTH 00024400 LABL84(23) = IDAY 00024500 LABL84(24) = IHR 00024600 C 00024700 C READ IN GRIDDED SNODEPTH DATA, ONE RECORD PER ROW OF GRID POINTS 00024800 C SAVE IN 2-D GRID ARRAY AFTER CONVERTING FROM 00024900 C 1) INTEGER*2 TO FLOATING POINT 00025000 C 2) TENTHS OF INCHES (INPUT VALUE "105"=10.5 INCHES) TO METERS 00025100 C 3) ICE FLAG OF 4090 TO ICE FLAG OF 11.0 00025200 C 4) AFGWC J-INDEX CONVENTION (TOP-DOWN) TO NMC (BOTTOM-UP) 00025300 C 00025400 C NOTE: OVER WATER POINTS ON INPUT GRID, INPUT VALUE IS EITHER 00025500 C 0 (NO SEA-ICE) OR 4090 (SEA-ICE FLAG VALUE) 00025600 C 00025700 DO 955 J=1,JAF 00025800 READ (20,ERR=980,END=990) IDATA 00025900 DO 950 I=1,IAF 00026000 IDAT4 = IDATA(I) 00026100 IF(IDAT4.NE.4090) THEN 00026200 SNODEP(I,JAFP1-J) = FLOAT(IDAT4) * 2.54E-3 00026300 ELSE 00026400 SNODEP(I,JAFP1-J) = 11.0E0 00026500 ENDIF 00026600 950 CONTINUE 00026700 955 CONTINUE 00026800 C 00026900 C PACK AFGWC USAF SNOW/ICE ANAL INTO O.N. 84 FORMAT 00027000 C 00027100 CALL W3FI32(LABL84,LBLF) 00027200 CALL W3AI00(SNODEP,PACKED,LBLF) 00027300 C 00027400 C CHECK O.N. 84 LABELS 00027500 C 00027600 C WRITE(6,956) LBLF(12),PACKED(12) 00027700 C WRITE(6,957) (LBLF(I), I=1,12) 00027800 C WRITE(6,958) (PACKED(I), I=1,12) 00027900 C 956 FORMAT(1H /1H ,'LBLF(12)=',I10,4X,'PACK(12)=',I10) 00028000 C 957 FORMAT(1H /1H ,'LBLF=', 6(2X,Z8)//1H , 6(2X,Z8)) 00028100 C 958 FORMAT(1H /1H ,'PACK=', 6(2X,Z8)//1H , 6(2X,Z8)) 00028200 C 00028300 C WRITE USAF AFGWC SNOW/ICE ANAL TO FILE 13 AS 4TH LOGICAL RECORD 00028400 C 00028500 WRITE(13) PACKED 00028600 C 00028700 C PRINT DATE OF FIELD 00028800 C 00028900 PRINT 960, IYR, MONTH, IDAY, IHR 00029000 960 FORMAT ( 1X, 'DATE OF SND ',I2,'/',I2,'/',I2, ' AT ',I2,'Z') 00029100 C 00029200 GO TO 1000 00029300 C 00029400 C HANDLE I/O ERRORS FOR UNIT 20 (THESE ARE NONFATAL TO RAFS NET) 00029500 C 00029600 980 PRINT 985 00029700 985 FORMAT (' READ ERROR ON UNIT 20 WITH USAF SNOW '/ 00029800 * ' CONTACT NESDIS SPN NET FOCAL POINT IN E/SP13 '/ 00029900 * ' THIS IS NONFATAL ERROR: RDAS/RAFS WILL TAKE BACKUP ACTION') 00030000 CALL W3LOG('$E',3, 00030100 * 'NONFATAL READ W/ USAF SNOW (JOB OK) CALL W/NMC22: ') 00030200 CALL W3TAGE('SSTSNOV ') 00030300 STOP 3 00030400 C 00030500 990 PRINT 995 00030600 995 FORMAT (' E-O-F ERROR ON UNIT 20 WITH USAF SNOW '/ 00030700 * ' CONTACT NESDIS SPN NET FOCAL POINT IN E/SP13 '/ 00030800 * ' THIS IS NONFATAL ERROR: RDAS/RAFS WILL TAKE BACKUP ACTION') 00030900 CALL W3LOG('$E',4, 00031000 * 'NONFATAL E-O-F W/ USAF SNOW (JOB OK) CALL W/NMC22:') 00031100 CALL W3TAGE('SSTSNOV ') 00031200 STOP 4 00031300 C 00031400 1000 CONTINUE 00031500 C 00031600 C RUN COMPLETES AS DESIRED 00031700 C 00031800 CALL W3LOG('$E') 00031900 CALL W3TAGE('SSTSNOV ') 00032000 STOP 00032100 END 00032200