PROGRAM LMP_1HDECLTG
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 GHIRARDELLI INITIALIZED IOSTAT TO PASS check
C all CHECK
C
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_1HDECLTG')
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
IF(INOFL.GE.1.AND.INOFL.LE.999.AND.IAMPLS.GE.-999.AND.
1 IAMPLS.LE.999)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