C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C nmcraobs.F C C SAMPLE READ PROGRAM FOR NMC RAWINSONDE OBSERVATION DATA C C only categories 51 (land surface data) and 8 (additional data) C are expected in the KuDA land rawinsonde data set. C C Copyright 1993, University Corporation for C Atmospheric Research, All Rights Reserved C C ADM (NCAR/ATD/RAF) 93 FEB 26 C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C-------------------------------------------------------------------- C C MAIN PROGRAM C C PROGRAM ADP77 C C ASKS USER FOR FILENAME AND DATE, SEARCHES FILE FOR RECORD C OF THAT DATE, DISPLAYS DATA, AND ASKS FOR NEXT RECORD C-------------------------------------------------------------------- PROGRAM ADP77 PARAMETER(MXLV8=16) PARAMETER(IDD=50,MX=128) DIMENSION P(MX),Z(MX),T(MX),H(MX),D(MX),F(MX),Q(MX) DIMENSION ZWZ(MX),DWZ(MX),FWZ(MX),QWZ(MX) CHARACTER ASTA*6,FLNM*128 CHARACTER YMD*20 INTEGER YEAR,MONTH,DAY LOGICAL NOTFND LOUT=6 IU=11 C 10 WRITE(*,*) C --- SET NO MATCHING RECORDS FOUND FLAG NOTFND=.TRUE. C --- SET CONDITION CODE TO ALL'S WELL ICC=0 WRITE(*,20) 20 FORMAT(1X,' Enter file name to read or ''quit'' -> ',$) READ(*,'(A)')FLNM IF (FLNM.EQ.'QUIT' .OR. FLNM.EQ.'quit') THEN ICC=4 GO TO 270 ELSE OPEN(IU,FILE=FLNM,STATUS='OLD',IOSTAT=IERR) IF(IERR.NE.0) THEN IF(IERR.EQ.118) THEN WRITE(*,30)FLNM 30 FORMAT(' CANNOT FIND FILE ',A6) GOTO 10 ELSE WRITE(*,40)IERR,FLNM 40 FORMAT(' ERROR OPENING FILE =',I9,' ',A6) C quit program - SYSTEM ERROR ICC=6 GO TO 270 ENDIF ENDIF ENDIF NRO=0 C --- NOW ENTER YYMMDD 50 WRITE(*,*) ICC=0 WRITE(*,60) 60 FORMAT(1X,' Enter YYMMDD or ''quit'' -> ',$) READ(*,'(A)') YMD IF (YMD.EQ.'QUIT' .OR. YMD.EQ.'quit') THEN ICC=4 GO TO 270 ELSE READ(YMD,'(I2,I2,I2)')YEAR,MONTH,DAY IF (YEAR.LT.90) THEN WRITE(*,*)' ERROR: YEAR MUST BE GREATER THAN 90' GO TO 50 ENDIF IF (MONTH.LT.1 .OR. MONTH.GT.12) THEN WRITE(*,*)' ERROR: MONTH NOT BETWEEN 1 AND 12' GO TO 50 ENDIF IF (DAY.LT.1 .OR. DAY.GT.31) THEN WRITE(*,*)' ERROR: DAY NOT BETWEEN 1 AND 31' GO TO 50 ENDIF ENDIF WRITE(*,*)' SEARCHING INPUT FILE' C C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C C READ first 50 characters of record NR=0 70 CONTINUE 80 CALL RDADP(IU,IDSRCH,IYR,IMO,IDY,IHR,IDSTYP,XLAT,XLON, 2 ASTA,XHR,IC25,IC26,IC27,IRTYP,XELEV,IINTYP,LTH,ISTAT) IF(ISTAT.NE.0) THEN ICC=ISTAT GO TO 270 ENDIF NR=NR+1 NRO=NRO+1 IF (IYR.GT.YEAR) THEN ICC = 2 GO TO 270 ELSEIF (IMO.GT.MONTH .AND. IYR.EQ.YEAR) THEN ICC = 2 GO TO 270 ELSEIF (IDY.GT.DAY .AND. IMO.EQ.MONTH .AND. IYR.EQ.YEAR) THEN ICC = 2 GO TO 270 ENDIF IF (IYR.NE.YEAR .OR. IMO.NE.MONTH .OR. IDY.NE.DAY) GO TO 70 WRITE(LOUT,90)ASTA,1 90 FORMAT(' ID - STATION ',A6,I10) WRITE(LOUT,100)IYR,IMO,IDY,IHR,XHR,XLAT,XLON,XELEV, 2 IRTYP 100 FORMAT(1X,3I3,I5,F6.2,1X,2F7.2,F6.0,1X,I4) C - - - - - - - - - - - - - - - - - - - - - - - - - - - - C CALL STKADP(P,Z,T,H,D,F,Q,NLV,MX) IF(NLV .LT. 1) GO TO 140 WRITE(LOUT,110)NLV 110 FORMAT(' MAN AND SIG LEVELS ',I10) NLVW=0 DO 130 I=1,NLV WRITE(LOUT,120)I,P(I),Z(I),T(I),H(I),D(I),F(I),Q(I) 120 FORMAT(1X,I4,6F8.1,1X,A4) 130 CONTINUE 140 CONTINUE C - - - - - - - - - - - - - - - - - - - - - - - - - - - - C WIND BY HEIGHT C 150 CONTINUE CALL WZZADP(ZWZ,DWZ,FWZ,QWZ,NLVWZ,MX) IF(NLVWZ.LT.1)GO TO 190 WRITE(LOUT,160)NLVWZ 160 FORMAT(' WIND BY HEIGHT ',I10) DO 180 I=1,NLVWZ WRITE(LOUT,170)I,ZWZ(I),DWZ(I),FWZ(I),QWZ(I) 170 FORMAT(1X,I4,3F8.1,5X,A3) 180 CONTINUE 190 CONTINUE C - - - - - - - - - - - - - - - - - - - - - - - - - - - - C TROPOPAUSE C 200 CONTINUE CALL TRPADP(P,T,H,D,F,Q,NLV,MX) IF(NLV.LT.1)GO TO 240 WRITE(LOUT,210)NLV 210 FORMAT(' TROPOPAUSE ',I10) DO 220 I=1,NLV 220 WRITE(LOUT,230)I,P(I),T(I),H(I),D(I),F(I),Q(I) 230 FORMAT (1X,I4,5F8.1,1X,A4) 240 CONTINUE C - - - - - - - - - - - - - - - - - - - - - - - - - - - - C AIRCRAFT REPORTS C CALL AFTADP(Z,T,H,D,F,Q,NLV,MX) IF(NLV .LT. 1) GO TO 270 WRITE(LOUT,250)NLV 250 FORMAT(' AIRCRAFT REPORT ',I10) DO 260 I=1,NLV 260 WRITE(LOUT,230)I,P(I),T(I),H(I),D(I),F(I),Q(I) C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 270 CONTINUE IF (ICC.EQ.0) THEN WRITE(*,275) 275 FORMAT('Press return for next record or enter ''quit'' -> ',$) READ(*,'(A)')FLNM IF (FLNM.EQ.'QUIT' .OR. FLNM.EQ.'quit') THEN WRITE(*,'(A)')'EXITING PROGRAM' GO TO 95 ENDIF C ----- LOOP BACK TO READ THE NEXT RECORD IN THE FILE WRITE(*,*) GO TO 70 ENDIF C ----- CLOSE THE INPUT FILE - A DIFFERENT ONE MAY BE OPENED NEXT CLOSE(UNIT=IU) IF (ICC.EQ.2) THEN C ----- LOOP BACK TO READ ANOTHER FILE IF (NOTFND) THEN WRITE (*,'(A)') 'NO RECORDS FOUND FOR DATE ENTERED' ENDIF GO TO 10 ELSEIF (ICC.EQ.4) THEN C ----- USER ENTERED QUIT SO STOP PROGRAM WRITE(*,'(A)')'EXITING PROGRAM' GO TO 95 ELSEIF (ICC.EQ.5) THEN C ----- END OF FILE, SO LOOP BACK TO READ ANOTHER FILE PRINT 280,NRO 280 FORMAT(' END OF FILE REACHED - # OF RECORDS=',I8) GO TO 10 ELSE C ----- UNKNOWN SYSTEM ERROR ON OPEN OR READ - STOP PROGRAM WRITE(*,'(A)')'UNRECOVERABLE ERROR' GO TO 95 ENDIF 95 CONTINUE STOP END C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C-------------------------------------------------------------------- C C SUBROUTINE RDADP C C reads 60 character header info: C 10 character YYMMDDHH block C 40 character Report Identification block (lat,lon) C-------------------------------------------------------------------- SUBROUTINE RDADP(IU,IDSRCH,IYR,IMO,IDY,IHR,IDSTYP,XLAT,XLON, 2 ASTA,XHR,IC25,IC26,IC27,IRTYP,XELEV,IINTYP,LTH,ISTAT) SAVE CHARACTER NBF*10000,ASTA*6 COMMON /ADPB/NBF COMMON/ADPC/NU,NA,LTHR DATA NU,NA,LTHR/99999,0,0/ NU=NU+LTHR 5 CONTINUE IST=1 READ(IU,'(A)',END=90)NBF IST=0 NU=1 C --- The first 10 characters of each record contain the year, C --- month, day, and hour (2x,4i2) of each observation C GET DATE FROM LEADER READ(NBF(1:10),'(2X,4I2)',ERR=80)IYR,IMO,IDY,IHR C GET ID FOR CURRENT REPORT NU=11 C --- The next 40 characters of each record contain the latitude, C --- longitude, etc. READ(NBF(NU:NU+39),1001,ERR=80)XLAT,XLON,ASTA,XHR, 2 IC25,IC26,IC27,IRTYP,XELEV,IINTYP,LTH 1001 FORMAT(F5.2,F5.2,A6,F4.2,4X,3A1,I3,F5.0,I2,I3) C LTHR=LTH*10 ISTAT=0 IF(LTHR.GT.40) RETURN C --- ERROR ENCOUNTERED 80 CONTINUE PRINT 1002,NU,NBF(NU:NU+39) 1002 FORMAT(' ERR IN RDADP- NU,NBF ',I5,1X,A40) GO TO 5 C -----end of file reached 90 CONTINUE ISTAT=5 RETURN END C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C-------------------------------------------------------------------- C C-------------------------------------------------------------------- SUBROUTINE MANADP(P,Z,T,H,D,F,Q,NCNT,MAXLEV) SAVE DIMENSION P(1),Z(1),T(1),H(1),D(1),F(1),Q(1) CHARACTER NBF*10000,NMSG*40 COMMON /ADPB/NBF COMMON/ADPC/NU,NA,LTHR DATA NMSG/'9999999999999999999999999999999999999999'/ DIMENSION PM(20) DATA PM/1000.,850.,700.,500.,400.,300.,250.,200.,150.,100.,70., 2 50.,30.,20.,10.,7.,5.,3.,2.,1./ NTU=NU+40 NCNT=0 NLV=0 C C LOOK FOR CATEGORY 1 2 CONTINUE IF(NBF(NTU:NTU+9).EQ.'END REPORT') GO TO 90 READ(NBF(NTU:NTU+9),'(I2,I3,I2,I3)',ERR=95)NCC,NTN,NENT,NCCC IF(NTN.LE.0) GO TO 95 IF(NCC.EQ. 1) GO TO 3 NTU=NU+10*(NTN-1) GO TO 2 C 3 CONTINUE 10 CONTINUE NLV=NENT IF (NLV .LE. MAXLEV) GO TO 12 PRINT 1001,NLV 1001 FORMAT('0TOO MANY LEVELS IN MANADP',I10) NLV=MAXLEV 12 CONTINUE NTU=NTU+10 DO 20 I=1,NLV P(I)=PM(I) READ(NBF(NTU:NTU+21),1002,ERR=95)Z(I),T(I),H(I),D(I),F(I),Q(I) 1002 FORMAT(F5.0,F4.1,F3.1,2F3.0,A4) 20 NTU=NTU+22 90 NCNT=NLV RETURN 95 CONTINUE PRINT 1003,NBF(NTU:NTU+21) 1003 FORMAT(' DECODE ERROR IN CAT01 ',A22) NCNT=-1 RETURN END C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C-------------------------------------------------------------------- C C-------------------------------------------------------------------- SUBROUTINE SIGADP(P,T,H,Q,NCNT,MAXLEV) SAVE DIMENSION P(1),T(1),H(1),Q(1) CHARACTER NBF*10000,NMSG*40 COMMON /ADPB/NBF COMMON/ADPC/NU,NA,LTHR DATA NMSG/'9999999999999999999999999999999999999999'/ NTU=NU+40 NCNT=0 NLV=0 C C LOOK FOR CATEGORY 2 2 CONTINUE IF(NBF(NTU:NTU+9).EQ.'END REPORT') GO TO 90 READ(NBF(NTU:NTU+9),'(I2,I3,I2,I3)',ERR=95)NCC,NTN,NENT,NCCC IF(NTN.LE.0) GO TO 95 IF(NCC.EQ. 2) GO TO 3 NTU=NU+10*(NTN-1) GO TO 2 C 3 CONTINUE 10 CONTINUE NLV=NENT IF (NLV .LE. MAXLEV) GO TO 12 PRINT 1001,NLV 1001 FORMAT('0TOO MANY LEVELS IN SIGADP',I10) NLV=MAXLEV 12 CONTINUE NTU=NTU+10 DO 20 I=1,NLV READ(NBF(NTU:NTU+14),1002,ERR=95)P(I),T(I),H(I),Q(I) 1002 FORMAT(F5.1,F4.1,F3.1,A3) 20 NTU=NTU+15 90 NCNT=NLV RETURN 95 CONTINUE PRINT 1003,NBF(NTU:NTU+14) 1003 FORMAT(' DECODE ERROR IN CAT02 ',A15) NCNT=-1 RETURN END C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C-------------------------------------------------------------------- C C SUBROUTINE STKADP C C-------------------------------------------------------------------- SUBROUTINE STKADP(P,Z,T,H,D,F,Q,NLV,MAXLEV) SAVE DIMENSION P(1),Z(1),H(1),D(1),F(1),Q(1),T(1) NLV=0 CALL MANADP(P,Z,T,H,D,F,Q,NMLV,MAXLEV) J=0 IF (NMLV .LE. 0) GO TO 6 DO 5 I=1,NMLV IF (T(I) .GT. 90. .AND. H(I) .GT. 90. .AND. Z(I) .GT. 90000. .AND. 2 D(I) .GT. 900.) GO TO 5 J=J+1 IF (J .EQ. I) GO TO 5 P(J)=P(I) Z(J)=Z(I) T(J)=T(I) H(J)=H(I) D(J)=D(I) F(J)=F(I) Q(J)=Q(I) 5 CONTINUE NMLV=J 6 CONTINUE MLEV=MAXLEV-NMLV I=NMLV+1 CALL SIGADP(P(I),T(I),H(I),Q(I),NSLV,MLEV) NLV=NMLV+NSLV IF (NSLV .EQ. 0) RETURN DO 10 J=I,NLV D(J)=999. F(J)=999. 10 Z(J)=99999. IF (NMLV .EQ. 0) RETURN IL=NMLV 15 IL=IL+1 16 IF (IL .GT. NLV) GO TO 40 IS=IL 18 IS=IS-1 IF (IS .LT. 1) GO TO 22 IF (P(IL) .GT. P(IS)) GO TO 18 IF (P(IL) .NE. P(IS)) GO TO 22 NLV=NLV-1 IF (IL .GT. NLV) GO TO 40 DO 20 K=IL,NLV J=K+1 P(K)=P(J) Z(K)=Z(J) T(K)=T(J) H(K)=H(J) D(K)=D(J) F(K)=F(J) 20 Q(K)=Q(J) GO TO 16 22 CONTINUE IS=IS+1 XP=P(IL) XZ=P(IL) XZ=Z(IL) XT=T(IL) XH=H(IL) XD=D(IL) XF=F(IL) QN=Q(IL) IB=1 IE=IL-IS DO 25 J=IB,IE K=IL-J L=K+1 P(L)=P(K) Z(L)=Z(K) T(L)=T(K) H(L)=H(K) D(L)=D(K) F(L)=F(K) 25 Q(L)=Q(K) P(IS)=XP Z(IS)=XZ T(IS)=XT H(IS)=XH D(IS)=XD F(IS)=XF Q(IS)=QN GO TO 15 40 CONTINUE RETURN END C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C-------------------------------------------------------------------- C C-------------------------------------------------------------------- SUBROUTINE TRPADP(P,T,H,D,F,Q,NCNT,MAXLEV) SAVE DIMENSION P(1),T(1),H(1),D(1),F(1),Q(1) CHARACTER NBF*10000,NMSG*40 COMMON /ADPB/NBF COMMON/ADPC/NU,NA,LTHR DATA NMSG/'9999999999999999999999999999999999999999'/ LCAT=5 XMUL=.1 GO TO 1 ENTRY AFTADP(P,T,H,D,F,Q,NCNT,MAXLEV) LCAT=6 XMUL=1. 1 CONTINUE NTU=NU+40 NCNT=0 NLV=0 C C LOOK FOR CATEGORY LCAT 2 CONTINUE IF(NBF(NTU:NTU+9).EQ.'END REPORT') GO TO 90 READ(NBF(NTU:NTU+9),'(I2,I3,I2,I3)',ERR=95)NCC,NTN,NENT,NCCC IF(NTN.LE.0) GO TO 95 IF(NCC.EQ. LCAT) GO TO 3 NTU=NU+10*(NTN-1) GO TO 2 C 3 CONTINUE 10 CONTINUE NLV=NENT IF (NLV .LE. MAXLEV) GO TO 12 PRINT 1001,NLV 1001 FORMAT('0TOO MANY LEVELS IN TXXADP',I10) NLV=MAXLEV 12 CONTINUE NTU=NTU+10 DO 20 I=1,NLV READ(NBF(NTU:NTU+21),1002,ERR=95)P(I),T(I),H(I),D(I),F(I),Q(I) 1002 FORMAT(F5.0,F4.1,F3.1,2F3.0,A4) P(I)=P(I)*XMUL 20 NTU=NTU+22 90 NCNT=NLV RETURN 95 CONTINUE PRINT 1003,LCAT,NBF(NTU:NTU+12) 1003 FORMAT(' DECODE ERROR IN CAT',I2,1X,A13) NCNT=-1 RETURN END C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C-------------------------------------------------------------------- C C SUBROUTINE WPPADP C & ENTRY WZZADP C C reads category 3 or category 4 data C-------------------------------------------------------------------- SUBROUTINE WPPADP(P,D,F,Q,NCNT,MAXLEV) SAVE DIMENSION P(1),D(1),F(1),Q(1) CHARACTER NBF*10000,NMSG*40 COMMON /ADPB/NBF COMMON/ADPC/NU,NA,LTHR DATA NMSG/'9999999999999999999999999999999999999999'/ LCAT=3 XMUL=.1 GO TO 1 ENTRY WZZADP(P,D,F,Q,NCNT,MAXLEV) LCAT=4 XMUL=1. 1 CONTINUE NTU=NU+40 NCNT=0 NLV=0 C C LOOK FOR CATEGORY LCAT 2 CONTINUE IF(NBF(NTU:NTU+9).EQ.'END REPORT') GO TO 90 READ(NBF(NTU:NTU+9),'(I2,I3,I2,I3)',ERR=95)NCC,NTN,NENT,NCCC IF(NTN.LE.0) GO TO 95 IF(NCC.EQ. LCAT) GO TO 3 NTU=NU+10*(NTN-1) GO TO 2 C 3 CONTINUE write(*,'(I2,A1,$)') LCAT,' ' 10 CONTINUE NLV=NENT IF (NLV .LE. MAXLEV) GO TO 12 PRINT 1001,NLV 1001 FORMAT('0TOO MANY LEVELS IN WXXADP',I10) NLV=MAXLEV 12 CONTINUE NTU=NTU+10 DO 20 I=1,NLV READ(NBF(NTU:NTU+12),1002,ERR=95)P(I),D(I),F(I),Q(I) 1002 FORMAT(F5.0,2F3.0,A2) P(I)=P(I)*XMUL 20 NTU=NTU+13 C ---- 'END REPORT FOUND' 90 NCNT=NLV RETURN 95 CONTINUE PRINT 1003,LCAT,NBF(NTU:NTU+12) 1003 FORMAT(' DECODE ERROR IN CAT',I2,1X,A13) NCNT=-1 RETURN END C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C * END OF FILE nmcraobs.F * C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *