PROGRAM CLPUTIL C C JANUARY 2023 SAMPLATSKY MDL MOS-2000 C C PURPOSE C PERFORM SOME BASIC UTILITY FUNCTIONS FOR THE CONVECTION, C LIGHTNING, AND POP SYSTEMS THAT DO NOT FIT IN ANYWHERE C ELSE. C C C VARIABLES C CONVERTX = CHARACTER VARIABLE HOLDING THE KEYWORD USED TO OPEN C OUTPUT FILE WITH THE CORRECT ENDIAN. C (CHARACTER*20) (INTERNAL). C C C VARIABLES C NUMVAR = NUMBER OF INPUT AND OUTPUT MRMS VARIABLES. C (PARAMETER) C IPACK(N) = ARRAY CONTAINING PACKED DATA IN TDLPACK GRID C INPUT FILE (N=1,ND1). (INTERNAL) C NID = MAXIMUM NUMBER OF VARIABLE IDS TO BE PROCESSED. C DIMENSION OF ID_OLD( , ), ID_NEW( , ), JTYPE( ). C ID_OLD(J,K) = VARIABLE IDS ON INPUT FILE (J=1,4; K=1,NID). C (INPUT) C ID_NEW(J,K) = VARIABLE IDS ON OUTPUT FILES (J=1,4; K=1,NID). C (INPUT) C NBYTES = NUMBER OF BYTES IN RECORD TO FOLLOW. C IS0( ) = MOS-2000 GRIB SECTION 0 (8 BYTES) C 1 - "TDLP" C 2 - RECORD LENGTH IN BYTES C IS1( ) = MOS-2000 GRIB SECTION 1 C 9-12 TDL 4-WORD ID C IS2( ) = MOS-2000 GRIB SECTION 2 C 2 - MAP PROJECTION C 3 - NX NUMBER OF GRID POINTS IN X DIRECTION C 4 - NY NUMBER OF GRID POINTS IN Y DIRECTION C 5 - LATITUDE OF LOWER LEFT CORNER, DEGREE*10000 C 6 - LONGITUDE OF LOWER LEFT CORNER, DEGREE*10000 C 7 - GRID ORIENTATION, DEGREE*10000 C 8 - GRID LENGTH, MILLIMETERS C 9 - LATITUDE AT WHICH MESH APPLIES, C DEGREES*10000; ALSO TANGENCY LATITUDE C IS4( ) = MOS-2000 GRIB SECTION 4 C L3264B = WORD LENGTH OF MACHINE YOU ARE RUNNING ON C 32 OR 64. C L3264W = 64/L3264B C ND7 = DIMENSION OF IS0( ), IS2( ), AND IS4( )(=60). C ND1 = DIMENSION OF IPACK( ) AND DATA( ) - THE C PACKED AND UNPACKED DATA, RESPECTIVELY. C ND1 = DIMENSION OF CCALL( ), THE "STATION CALL C LETTERS". C KREC = COUNTER FOR ALL PACKED DATA RECORDS READ FROM C INPUT FILE. (INTERNAL) C ISTRT = FIRST UNPACKED "DATA" RECORD TO PRINT OUT. C (INPUT) C IFIN = LAST UNPACKED "DATA" RECORD TO PRINT OUT. C (INPUT) C JTYPE(N) = THE TYPE OF OUTPUT FOR THE CERTAIN ID (N=1,NID). C = 1 VECTOR FILE, = 2 GRID FILE, = 3 BOTH C C COMMON BLOCKS: NONE C C C SUBPROGRAMS CALLED: C UNPACK, UPDAT, WRVTGD C C23456789112345678921234567893123456789412345678951234567896123456789712 C PARAMETER (ND1=4000000,ND7=60,L3264B=32,L3264W=64/L3264B) C DIMENSION GFSDATA(8,ND1),DATA(ND1) C DIMENSION IS0(ND7),IS1(ND7),IS2(ND7),IS4(ND7),IPACK(ND1), 1 IWORK(ND1),ISTA(ND1),IPLAIN(L3264W,4),ID(4),NBYTES(2) C CHARACTER*1 STA1(8),XTMP CHARACTER*32 PLAIN CHARACTER*8 CCALL(ND1),STA8(1) CHARACTER*60 INFILE,OUTFILE,DATFILE CHARACTER*255 JUNK C EQUIVALENCE (IPLAIN,PLAIN) EQUIVALENCE (STA8,STA1) CINTEL CHARACTER(LEN=20) :: CONVERTX C CONVERTX='BIG_ENDIAN' CINTEL DATA KFILDI/5/,KFILDO/6/,KFILVT/99/ DATA PLAIN/' '/ C NBYWD = L3264B/8 C CALL W3TAGB('LMP_CLPUTIL',2023,20,80,'OST13') CALL TIMPR(KFILDO,KFILDO,'START CLPUTIL ') C C READ CONTROL FILE INFO C READ(KFILDI,100) JUNK READ(KFILDI,100) JUNK 100 FORMAT(A255) READ(KFILDI,105) (ID(J),J=1,4) 105 FORMAT(3I10,I11) C READ(KFILDI,110) KFILDT,DATFILE READ(KFILDI,110) IJUNK,JUNK READ(KFILDI,110) KFILIN,INFILE READ(KFILDI,110) IJUNK,JUNK READ(KFILDI,110) KFILOUT,OUTFILE 110 FORMAT(I3,4X,A60) C C INITIALIZE IOSTAT IOSTAT=0 C WRITE(KFILDO,120) ID(1),KFILDT,DATFILE,KFILIN,INFILE, 1 KFILOUT,OUTFILE 120 FORMAT(/,' 1ST WORD OF ID: ',I10.9, 1 /,' UNIT AND NAME OF DATE FILE: ',I2,2X,A60, 2 /,' UNIT AND NAME OF INPUT FILE: ',I2,2X,A60, 3 /,' UNIT AND NAME OF OUTPUT FILE: ',I2,2X,A60) C C OPEN DATE FILE WITH CONVERT= SPECIFIER C OPEN(UNIT=KFILDT,FORM='FORMATTED',STATUS='OLD', 1 IOSTAT=IOS,ERR=150) 150 IF (IOSTAT.NE.0) THEN WRITE(KFILDO,155)KFILDT,IOS 155 FORMAT(/,' ****TROUBLE OPENING FILE ON UNIT NO.',I3, 1 '. IOSTAT =',I5,' STOP 150') CALL W3TAGE('LMP_CLPUTIL') STOP 150 ENDIF C C READ AND PRINT THE DATE TO BE PROCESSED C CALL GET_NCEPDATE(KFILDT,IYR,IMO,IDA,IHR,KDATE,IER) C IF(IER.NE.0)THEN WRITE(KFILDO,160) 160 FORMAT(/' ****ERROR: CAN NOT READ NCEP DATE FILE - ', 1 'FATAL ERROR IN CLPUTIL. STOP 160.') CALL W3TAGE('LMP_CLPUTIL') STOP 160 ENDIF C WRITE(KFILDO,170) KDATE 170 FORMAT(/,'DATE-HOUR TO WRITE TO OUTPUT FILE:',2X,I10) C C OPEN TDLPACK GRID INPUT AND OUTPUT FILES (BIG-ENDIAN). C OPEN(UNIT=KFILIN,FORM='UNFORMATTED', 1 STATUS='OLD',CONVERT=CONVERTX,IOSTAT=IOS,ERR=200) C 200 IF (IOSTAT.NE.0) THEN WRITE(KFILDO,210) KFILIN,IOS 210 FORMAT(/,' **** TROUBLE OPENING INPUT FILE UNIT NO.',I3, 1 '. IOSTAT=',I5,' STOP 200') CALL W3TAGE('LMP_CLPUTIL') STOP 200 END IF C OPEN(UNIT=KFILOUT,FORM='UNFORMATTED', 1 STATUS='NEW',CONVERT=CONVERTX,IOSTAT=IOS,ERR=250) C 250 IF (IOSTAT.NE.0) THEN WRITE(KFILDO,260) KFILOUT,IOS 260 FORMAT(/,' **** TROUBLE OPENING OUTPUT FILE UNIT NO.',I3, 1 '. IOSTAT=',I5,' STOP 250') CALL W3TAGE('LMP_CLPUTIL') STOP 250 END IF C C THE DO LOOP BELOW IS ONLY FOR THE PURPOSE OF NOT ADDING A GO C TO STATEMENT FOR FILE READING. WHEN THE EOF IS REACHED, A C CLEAN EXIT WILL OCCUR. C DO K=1,9999 C 300 READ (UNIT=KFILIN,END=890,ERR=900) 1 (NBYTES(J),J=1,L3264W), 2 (IPACK(J),J=1,NBYTES(L3264W)/NBYWD) C C CHECK IF THE ID MATCHES WHAT IS WAS READ FROM CONTROL FILE. C WRITE(KFILDO,305) K,(IPACK(J),J=5,9) 305 FORMAT(' RECORD ',I5,' READ IN, DATE AND ID: ',I12,4I11.9) IF ((IPACK(6).EQ.ID(1)).AND.(IPACK(7).EQ.ID(2)).AND. 1 (IPACK(8).EQ.ID(3)).AND.(IPACK(9).EQ.ID(4))) THEN C C IF THE ID IS FOR ALASKA LIGHTNING, CHANGE THE DATE ON THE C RECORD FROM THE BEGINNING OF THE VALID PERIOD, TO THE END. C OTHERWISE, NDATE IS PRECISELY WHAT WAS READ IN. C IF (IPACK(6).EQ.707380004) THEN CALL UPDAT(IPACK(5),1,NDATE) MESH=10 ! don't know why, but it needs defining ELSE NDATE=IPACK(5) END IF C C UNPACK DATA RECORD. C CALL UNPACK(KFILDO,IPACK,IWORK,DATA,ND1,IS0,IS1,IS2, 1 IS4,ND7,MISSP,MISSS,2,L3264B,IER) C IF (IER.NE.0) THEN WRITE(KFILDO,340) IER,(IPACK(J),J=5,9) 340 FORMAT(/,' **** IER=',I5,' WHEN TRYING TO UNPACK RECORD', 1 I12,4I10.9,' ... FATAL ERROR, STOP 340') CALL W3TAGE('LMP_CLPUTIL') STOP 340 END IF C C IF THE ID READ IN IS 1H PRECIP, CONVERT FROM CONTINUOUS TO C BINARY. A THRESHOLD VARIABLE IS USED BELOW FOR THIS. C IF (IPACK(6).EQ.703201004) THEN THRESH=0.0095 DO N=1,ND1 IF (DATA(N).LT.9998.5) THEN IF (DATA(N).GT.THRESH) DATA(N)=1.0 ELSE DATA(N)=0.0 END IF END DO MESH=5 ! not sure why, but this needs defining END IF C C SETTING PARAMETERS OF OUTPUT GRID DOMAIN C ALAT=IS2(5)*1.0/10000. ALON=IS2(6)*1.0/10000. ORIENT=IS2(7)*1.0/10000. XMESHL=IS2(8)*1.0/1000. XLAT=IS2(9)*1.0/10000. NPROJ=IS2(2) NX=IS2(3) NY=IS2(4) NSTA=NX*NY ITYPE=2 C C C CALL ROUTINE TO PACK AND WRITE EACH QC'D VARIABLE IN C TDLPACK GRID FORMAT. C WRITE(KFILDO,500) NDATE,(ID(J),J=1,4) 500 FORMAT(' WRITING TO OUTPUT, DATE AND ID: ',I10,4I11.9) CALL WRVTGD(KFILDO,KFILVT,KFILOUT,ID,NDATE,CCALL,DATA, 1 NSTA,ALAT,ALON,ORIENT,MESH,XLAT,NX,NY,ND7, 2 IS1(17),IS1(18),ITYPE,L3264B,L3264W,ISTOP, 3 IPLAIN,PLAIN,IERV,IERG,NPROJ) C END IF ! IF THIS IS AN ID TO PROCESS END DO ! LOOPING THROUGH THE FILE C C IF THE FOLLOWING WRITE STATEMENT OCCURS, THEN THERE WAS C NEVER A MATCHING ID FOUND ON THE INPUT FILE. PRINT AN C ALERT MESSAGE. C IF (K.GE.9999) THEN WRITE(KFILDO,888) (ID(J),J=1,4) 888 FORMAT(/,' **** THE ID ',4I11.9,' WAS NEVER FOUND IN THE', 1 ' INPUT DATA FILE. THERE WAS LIKELY A PROBLEM IN', 2 ' PRIOR PROCESSING.') END IF C 890 CALL TIMPR(KFILDO,KFILDO,'END CLPUTIL ') STOP C C ERRORS IN READING INGEST DATA C 900 WRITE(KFILDO,910) KFILIN 910 FORMAT(/,' **** ERRORS WERE ENCOUNTERED TRYING TO READ KFILIN.', 1 ' STOP 300') CALL W3TAGE('LMP_CLPUTIL') STOP 300 C END