PROGRAM LMP_AK_DECLTG C C NOVEMBER 2013 KOCHENASH MDL MOS-2000 C APRIL 2017 SAMPLATSKY SLIGHT REWORK TO REMOVE A COUPLE C GOTO STATEMENTS, ALSO ADDED SOME C DOCUMENTATION. C DECEMBER 2017 SAMPLATSKY MODIFIED LOGIC SURROUNDING LABEL C 95 TO NOT ENTIRELY STOP PROCESS C DUE TO A BUFR READ ERROR. IT IS C VERY POSSIBLE THAT NO LIGHTNING C IS OCCURRING, AND WE WANT THE C PROCESS TO CONTINUE IN THIS CASE. C SEPTEMBER 2020 SAMPLATSKY INITIALIZE IOSTAT=0 DUE TO CHECK C ALL COMPILER OPTION. C C PURPOSE C READS AND DECODES LIGHTNING DATA FROM THE BUFR TANKS USING C BUFR LIBRARY ROUTINES. THE OUTPUT IS AN ASCII FILE CONTAINING C LIGHTNING FLASHES, BY TIME AND LOCATION. C C VARIABLES C C KFILDO = UNIT NUMBER FOR STANDARD OUTPUT C LUBFR = LOGICAL UNIT FOR BUFR FILE (INPUT) C MAXT = MAXIMUM NUMBER OF STRIKES TO RETURN (INPUT) C RPTIME(NRPTIME,255) = UP TO NRPTIME(6) VARIABLE NAMES ARE ALLOWED C FOR DECODING BUFR MESSAGES. C THESE INCLUDE: C YEAR = YEAR C MNTH = MONTH C DAYS = DAY C HOUR = HOUR C MINU = MINUTES C SECO = SECONDS C (NRPTIME=6), (INTERNAL) C LTGARR(NLTG,255) = UP TO NLTG(5) VARIABLE NAMES ARE ALLOWED FOR C DECODING LIGHTNING BUFR MESSAGES. C THESE INCLUDE: C CLATH = LATITUDE (HIGH ACCURACY) C CLONH = LONGITUDE (HIGH ACCURACY) C NOFL = NUMBER OF FLASHES (THUNDERSTORM) C AMPLS = AMPLITUDE OF LIGHTNING STRIKE C PLRTS = POLARITY OF STROKE C (NLTG=5), (INTERNAL) C LYR_T(),LMONTH_T(), C LDAY_T() = YEAR, MONTH, DAY OF EACH STRIKE. MUST BE C DIMENSIONED BY MAXT IN CALLING ROUTINE (OUTPUT) C LHR_T(),LMIN_T(), C LSEC_T(),LSEC10_T() = HOUR, MINUTE, SECOND, 1/10 SECONDS OF EACH C STRIKE. MUST BE DIMENSIONED MAXT IN CALLING C ROUTINE (OUTPUT) C LAMP_T() = STRIKE AMPLITUDE IN +/- KILOAMPS (OUTPUT) C LMULT_T() = FLASH MULTIPLICITY OF EACH STRIKE (OUTPUT) C RLAT_T(),RLON_T() = NORTH LATITUDE AND EAST LONGITUDE OF STRIKES, C DIMENSIONED BY MAXT IN CALLING ROUTINE (OUTPUT) C NTOTAL = TOTAL NUMBER OF STRIKES IN TIME WINDOW (OUTPUT) C IER = OUTPUT CONDITION CODE, AS FOLLOWS: C 0 : NO PROBLEMS C 57: BUFR FILE CONTAINS NO MESSAGES C C SUBPROGRAMS CALLED: C LIBRARY: C BUFRLIB: C OPENBF - OPENS A BUFR FILE C READMG - ADVANCES INPUT MESSAGE POINTER C READSB - READS AND UNPACKS DATA FROM A SUBSET C WITHIN A BUFR MESSAGE C UFBINT - LOGICAL I/O, TRANSFERS DATA FROM SUBSET BUFR C FILE TO ARRAY, USED FOR SINGLE VALUE C MNEMONICS C PARAMETER (NLTG=5) PARAMETER (NRPTIME=6) C INTEGER IDATE,IRET,JJ,IEOF,NRET, 1 IYEAR,IMNTH,IDAYS,IHOUR,IMINU,ISECO,ISEC10, 2 INOFL,IAMPLS,IPLRTS,ISTYPE C REAL RLAT,RLON C REAL*8 RPTIME(NRPTIME,255),LTGARR(NLTG,255),ARR2(1,255) C CHARACTER(LEN=80) :: STRING CHARACTER(LEN=8) :: SUBSET C DATA LUBFR/42/,IUNIT/30/,TABLE/60/,RAW/70/,TMPTBL/80/ DATA KFILOUT/20/,KFILDO/6/ IER = 0 NTOTAL = 0 IOSTAT = 0 C C OPEN OUTPUT ASCII FILE C OPEN(UNIT=KFILOUT,STATUS="NEW",FORM="FORMATTED",IOSTAT=IOS, 1 ERR=50) C 50 IF (IOSTAT.NE.0) THEN WRITE(KFILDO,60) KFILOUT,IOSTAT 60 FORMAT(/,' **** ERROR OPENING OUTPUT ASCII FILE, UNIT ',I3, 1 ' ... STOP 50') CALL W3TAGE('LMP_AK_DECLTG') END IF C C OPEN BUFR FILE C CALL OPENBF(LUBFR,'IN',LUBFR) C C READMG ADVANCES THE INPUT MESSAGE POINTER TO THE C NEXT BUFR MESSAGE IN THE FILE AND READS THE MESSAGE, C WITHOUT CHANGE, INTO AN INTERNAL BUFFER. C C READMG RETURNS -1 IF NO BUFR MESSAGE IS READ C C UPDATE 12/11/17 - DO NOT CALL W3TAGE WHEN AN ERROR IS RETURNED C HERE. STILL STOP, HOWEVER DOWNSTREAM JOBS C SHOULD STILL CONTINUE TO RUN. C CALL READMG(LUBFR,SUBSET,IDATE,IRET) IF (IRET.NE.0)THEN IER = 57 WRITE (KFILDO,95) IRET 95 FORMAT(/,' **** ERROR ATTEMPTING TO READ BUFR FILE, IRET=',I5, 1 /,' THIS IS NOT NECESSARILY AN ERROR AND LIKELY', 2 /,' A RESULT OF NO LIGHTNING OCCURRENCE. STOP', 3 /,' 95 HERE, AND DOWNSTREAM JOBS WILL REACT', 4 /,' ACCORDINGLY.') C95 FORMAT(/,' **** ERROR ATTEMPTING TO READ BUFR FILE, IRET=',I5, C 1 ' ... IER=57, STOP 95') C CALL W3TAGE('LMP_1HDECLTG') STOP 95 ENDIF C C READSB READS AND UNPACKS THE BUFR MESSAGE PLACED IN C THE INTERNAL BUFFER BY READMG INTO AN INDEXED AND C EXPANDED INTERNAL BUFFER. C 100 CALL READSB(LUBFR,IRET) C IF (IRET.EQ.0) THEN C C UFBINT TRANSFERS DATA VALUES FROM THE INTERNAL BUFFER. C DO JJ=1,NRPTIME RPTIME(JJ,1)=0.1E+12 ENDDO STRING = ' YEAR MNTH DAYS HOUR MINU SECO ' CALL UFBINT(LUBFR,RPTIME,6,255,NRET,STRING) C C PARSE INFO FROM BUFR MESSAGE C IYEAR=NINT(RPTIME(1,1)) IMNTH=NINT(RPTIME(2,1)) IDAYS=NINT(RPTIME(3,1)) IHOUR=NINT(RPTIME(4,1)) IMINU=NINT(RPTIME(5,1)) ISECO=INT(RPTIME(6,1)) ISEC10=(RPTIME(6,1)-ISECO)*100 C DO JJ=1,NLTG LTGARR(JJ,1)=0.1E+12 ENDDO STRING = ' CLATH CLONH NOFL AMPLS PLRTS ' CALL UFBINT(LUBFR,LTGARR,5,255,NRET,STRING) RLAT=LTGARR(1,1) RLON=LTGARR(2,1) INOFL=NINT(LTGARR(3,1)) IAMPLS=NINT(LTGARR(4,1)) IAMPLS = IAMPLS / 1000 IPLRTS=NINT(LTGARR(5,1)) C C POLARITY CODE 2 MEANS NEGATIVE AMPLITUDE C IF(IPLRTS.EQ.2) IAMPLS = -1 * IAMPLS CALL UFBINT(LUBFR,ARR2,1,255,NRET,'OWEP') IF(ARR2(1,1).EQ.4096.) ISTYPE=1 IF(ARR2(1,1).EQ.8192.) ISTYPE=0 C C IF(INOFL.GE.1.AND.INOFL.LE.999.AND.IAMPLS.GE.-999.AND. C 1 IAMPLS.LE.999)THEN IF(IAMPLS.GE.-999.AND.IAMPLS.LE.999.AND. 2 RLON.LE.180)THEN C C WRITE FLASH INFO TO OUTPUT C WRITE(KFILOUT,175) IMNTH,IDAYS,IYEAR-2000,IHOUR,IMINU, 1 ISECO,RLAT,RLON,IAMPLS,ISTYPE,INOFL 175 FORMAT (I2.2,',',I2.2,',',I2.2,',',I2.2,',',I2.2,',',I2.2, 1 ',',F8.3,',',F9.3,','I8,',kA, ',I1,',',I3) END IF C GOTO 100 ! READ ANOTHER MESSAGE C ELSE CALL READMG(LUBFR,SUBSET,IDATE,IEOF) IF(IEOF.EQ.0) GOTO 100 ! READ ANOTHER MESSAGE END IF C STOP END