C----------------------------------------------------------------- C RDFLDS.FOR C READ GULF MESOSCALE 33X33 FIELDS C (FOR 1 CYCLE STARTING AT IREC) C C Copyright 1992, University Corporation for C Atmospheric Research, All Rights Reserved C C RECEIVED FROM NOAA/ARL C MODIFIED MARCH 25, 1992 (ADM RAF/NCAR) C---------------------------------------------------------------- PROGRAM MAIN C**DECLARE DISPLAY SUBROUTINE SHOWIT EXTERNAL EXTERNAL SHOWIT EXTERNAL INIT CHARACTER*4 AFLD CHARACTER*50 ALBL CHARACTER*1 PDAT(1089) CHARACTER*30 FNAME(8) CHARACTER*40 ANSWER INTEGER MONTH(7:9, 31, 4, 2) LOGICAL MRF_FLAG C**FIELDS DIMENSION PRES(33,33),PREC(33,33) DIMENSION U(33,33,9),V(33,33,9),T(33,33,9),Q(33,33,9) C------------------------------ MRF_FLAG = .FALSE. C**GET DATE/TIME GROUP FROM USER 3 WRITE(*,*) WRITE(*,'(1X,''DATE/TIME GROUPS ARE ENTERED AS YYMMDDHHFF'')') WRITE(*,'(1X,''WHERE YY IS YEAR, MM IS MONTH, DD IS DAY,'')') WRITE(*,'(1X,''HH IS HOUR, AND FF IS FORECAST PERIOD'')') WRITE(*,*) WRITE(*,'(1X,''DATE/TIME GROUPS ARE FROM 9107220606'')') WRITE(*,'(1X,''TO 9109160606 WITH SOME MISSING'')') WRITE(*,*) WRITE(*,'(1X,''POSSIBLE HOURS ARE 00, 06, 12, AND 18'')') WRITE(*,'(1X,''POSSIBLE FORECAST PERIODS ARE 00 AT 00,12Z'')') WRITE(*,'(1X,'' AND 06 AT 06,18Z'')') WRITE(*,*) WRITE(*,'(/1X,''ENTER DATE/TIME GROUP or QUIT->'')') READ(*,'(A)') ANSWER IF (ANSWER.EQ.'QUIT' .OR. ANSWER.EQ.'quit') THEN IYY=-1 !set flag to QUIT ELSE READ(ANSWER,'(5I2)') IYY,IMM,IDD,IHH,IFHH ENDIF C------------------------------ C**CHECK WHETHER ALL ENTRIES ARE IN RANGE IF (IYY.EQ.-1) THEN WRITE(*,'(1X,''Exiting program.'')') GOTO 99 ELSEIF (IYY.NE.91) THEN WRITE(*,'(1X,''ERROR: YEAR MUST BE 91'')') GOTO 3 ELSEIF (IMM.LT.7 .OR .IMM.GT.9) THEN WRITE(*,'(1X,''ERROR: MONTH MUST BE 7,8, OR 9'')') GOTO 3 ELSEIF (IDD.LT.1 .OR .IDD.GT.31) THEN WRITE(*,'(1X,''ERROR: DAY MUST BE FROM 1 TO 31'')') GOTO 3 ELSEIF (IHH.NE.0 .AND .IHH.NE.6 .AND. + IHH.NE.12 .AND. IHH.NE.18) THEN WRITE(*,'(1X,''ERROR: HOUR MUST BE 00,06,12, OR 18'')') GOTO 3 ELSEIF (IFHH.NE.0 .AND .IFHH.NE.6) THEN WRITE(*,'(1X,''ERROR: DAY MUST BE 00 OR 06'')') GOTO 3 ENDIF C------------------------------ C** INITIALIZE FNAME AND MONTH ARRAYS CALL INIT(FNAME, MONTH) C------------------------------ C**CHECK IF DATE/TIME GROUP IS OUT OF RANGE IF (MONTH(IMM,IDD,(IHH/6)+1,2).EQ.0) THEN WRITE(*,'(1X,''ERROR: OUT OF RANGE'')') WRITE(*,'(1X,''ENTER FROM 9107220600 TO 9109160606'')') GOTO 3 ENDIF C------------------------------ C**CHECK IF DATE/TIME GROUP IS MISSING IF (MONTH(IMM,IDD,(IHH/6)+1,1).EQ.0) THEN WRITE(*,'(1X,''THIS DATE/TIME GROUP IS MISSING'')') GOTO 3 ENDIF C------------------------------ C**CHECK IF MRF FILE EXISTS C**OPEN MET DATA FILE OPEN(10,FILE=FNAME(MONTH(IMM,IDD,(IHH/6)+1,2)), + FORM='UNFORMATTED',RECL=1139,ACCESS='DIRECT', + STATUS='OLD',ERR=95,IOSTAT=IOS) C**OPEN OUTPUT FILE NOAA_ARL.MRF IF (.NOT.MRF_FLAG) THEN OPEN(UNIT=2, FILE='NOAA_ARL.MRF',FORM='FORMATTED', + ACCESS='SEQUENTIAL', STATUS='NEW',ERR=96,IOSTAT=IOS2) MRF_FLAG=.TRUE. ENDIF C------------------------------ C**INITIALIZE START RECORD IREC=MONTH(IMM,IDD,(IHH/6)+1,1) C**READ 2 SURFACE FIELDS DO 10 IFLD=1,2 READ(10,REC=IREC,END=99) ALBL,PDAT READ(ALBL,'(7I2.2,A4,I4,2E14.7)') IYR,IMN,IDY, : IHR,IFHR,ILVL,NGRID,AFLD,NEXP,PRECSN,VAR1 IREC=IREC+1 IF (IFHR.NE.IFHH) THEN WRITE(*,'(1X,''FORECAST HOUR NOT AVAILABLE'')') GOTO 3 ENDIF C**UNPACK THE SURFACE PRESSURE AND PRECIPITATION ARRAYS GOTO(11,12) IFLD C** PRES holds pressure 11 CALL UNPACK(PRES(1,1),PDAT,33,33,33*33,NEXP,VAR1) GO TO 10 C** PREC holds accumulated total precipitation 12 CALL UNPACK(PREC(1,1),PDAT,33,33,33*33,NEXP,VAR1) 10 CONTINUE C------------------------------ C**READ 9 LEVELS DO 30 L=1,9 C**READ 4 FIELDS (PER LEVEL) DO 20 IFLD=1,4 READ(10,REC=IREC) ALBL,PDAT READ(ALBL,'(7I2.2,A4,I4,2E14.7)') IYR,IMN,IDY, : IHR,IFHR,ILVL,NGRID,AFLD,NEXP,PRECSN,VAR1 IREC=IREC+1 C** UNPACK THE 2D ARRAYS AFTER THEY ARE READ IN GOTO(21,22,23,24) IFLD C** U holds UWND U wind component (East-West) 21 CALL UNPACK(U(1,1,L),PDAT,33,33,33*33,NEXP,VAR1) GO TO 20 C** V holds VWND V wind component (North-South) 22 CALL UNPACK(V(1,1,L),PDAT,33,33,33*33,NEXP,VAR1) GO TO 20 C** T holds TEMP Temperature 23 CALL UNPACK(T(1,1,L),PDAT,33,33,33*33,NEXP,VAR1) GO TO 20 C** Q holds SPHU Specific humidity 24 CALL UNPACK(Q(1,1,L),PDAT,33,33,33*33,NEXP,VAR1) 20 CONTINUE 30 CONTINUE C------------------------------ C**ARRAYS HAVE NOW BEEN STUFFED WITH DATA C**SO CALL A SUBROUTINE TO DO SOMETHING WITH THE DATA CALL SHOWIT(PRES, PREC, U, V, T, Q) C------------------------------ C**FILL FILE NOAA_ARL.MRF WITH THE DATA IN ASCII DO 80 I=1,3 DO 75 J=1,3 WRITE(UNIT=2,FMT=73) I,J, PRES(I,J),PREC(I,J), + (U(I,J,K),V(I,J,K),T(I,J,K),Q(I,J,K),K=1,9) 73 FORMAT(I3,I3,38(E14.7,1X)) 75 CONTINUE 80 CONTINUE CLOSE(UNIT=2) C------------------------------ GOTO 3 ! loop around to get another time selection 95 IF (IOS.NE.0) THEN WRITE(*, '(A)') ' **** ERROR ****' WRITE(*, '(A)') 'THE FILE CONTAINING THIS DATE/TIME' WRITE(*, '(A)') 'IS NOT CONTAINED IN YOUR DIRECTORY' GOTO 3 ENDIF 96 IF (IOS2.NE.0) THEN WRITE(*, '(A)') ' **** ERROR ****' WRITE(*, '(A)') 'FILE NOAA_ARL.MRF ALREADY EXISTS' ENDIF 99 STOP END C------------------------------ C------------------------------ C---------------------------------------------------------------- SUBROUTINE UNPACK(QVAR,QPACK,NX,NY,NXY,NEXP,VAR1) CHARACTER*1 QPACK(NXY) REAL*4 QVAR(NX,NY) SCALE=2.0**(7-NEXP) QOLD=VAR1 INDX=0 DO 400 J=1,NY DO 300 I=1,NX INDX=INDX+1 QVAR(I,J)=(ICHAR(QPACK(INDX))-127.)/SCALE+QOLD QOLD=QVAR(I,J) 300 CONTINUE QOLD=QVAR(1,J) 400 CONTINUE RETURN END C---------------------------------------------------------------- C** END OF NOAA_ARL.F C----------------------------------------------------------------