SUBROUTINE SPRT(TDATA,TGES,NTDTA,NTRECS,NLAT,NLON,NSIG, * TFILE,ERMAX,ERMIN,GROSS) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: SPRT SAVE OBS INFOR. FOR CONV. TEMPS. C PRGMMR: PARRISH ORG: W/NMC22 DATE: 90-10-12 C C ABSTRACT: SAVE OBS INFOR. FOR CONV. TEMPS. C C PROGRAM HISTORY LOG: C 90-10-12 PARRISH C C INPUT ARGUMENT LIST: C TDATA - OBS INFO AT OBS LOCATIONS C TGES - GUESS TEMPERATURE C NTDTA - NUMBER OF OBS C NLAT - NUMBER OF LATITUDES ON GAUSSIAN GRID C NLON - NUMBER OF LONGITUDES ON GAUSSIAN GRID C NSIG - NUMBER OF LAYERS ON GAUSSIAN GRID C ERMAX,ERMIN,GROSS - PARAMETERS FOR GROSS ERROR TEST OF DATA C C OUTPUT ARGUMENT LIST: C NTRECS - NUMBER OF TEMPERATURE RECORDS ON IUNIT C C ATTRIBUTES: C LANGUAGE: CFT77 C MACHINE: CRAY YMP C C$$$ C C-CRA DIMENSION TDATA(NTDTA,8),TGES(NTDTA) C-CRA DIMENSION NUMTEMPS(NSIG) C-CRA DIMENSION TPLTY(NSIG) C-CRA DIMENSION ICOUNT(NLAT,NLON,NSIG),NCOUNT(NTDTA+2*NLAT*NLON) C WARNING !! DIMENSION TDATA(_NTDTA_,8),TGES(_NTDTA_) DIMENSION TDATA(60000,8),TGES(60000) C DIMENSION NUMTEMPS(28) DIMENSION TPLTY(28) DIMENSION ICOUNT(96,192,28) C C DIMENSION NCOUNT(_NTDTA_+2*96*192) DIMENSION NCOUNT(60000+2*96*192) C DIMENSION TFILE(*) DIMENSION JL(128,6) C-------- C-------- LOCAL SPACE C-------- C-------- OBERMAX=-1.E50 OBERMIN=1.E50 RESMAX=-1.E50 RATMAX=-1.E50 NUMGROSS=0 C-CRA NUMTEMPS=0 C DIMENSION NUMTEMPS(NSIG) DO ITMP=1,NSIG NUMTEMPS(ITMP)=0 ENDDO C-CRA TPLTY=0. C DIMENSION TPLTY(NSIG) DO ITMP=1,NSIG TPLTY(ITMP)=0. ENDDO NTOT=0 NSATOT=0 IER=1 ILON=2 ILAT=3 ISIG=4 ITRES=5 ITYPE=8 NLTH=NLAT/2 NPP=16 C INCREASE OBS ERRORS IN THE N.H. BY A FACTOR OF 2 TO ACCOUNT C FOR N.S. GUESS ERROR DIFFERENCE FACTOR=2.0 ANLON=FLOAT(NLON) C NTTOT=NTDTA+2*NLAT*NLON NTTOT=NTDTA NDTTOT=0 C-CRA NCOUNT=0 C DIMENSION ICOUNT(NLAT,NLON,NSIG),NCOUNT(NTDTA+2*NLAT*NLON) DO ITMP=1,NTDTA+2*NLAT*NLON NCOUNT(ITMP)=0 ENDDO INC=NTTOT/128 INC=MAX(INC,1) NRECS=0 IS=1 DO 200 KK=1,NTTOT C-CRA ICOUNT=0 C DIMENSION ICOUNT(NLAT,NLON,NSIG),NCOUNT(NTDTA+2*NLAT*NLON) DO ITMP=1,NLAT*NLON*NSIG ICOUNT(ITMP,1,1)=0 ENDDO I128=1 ISSAVE=IS IS=IS+1 NUMDAT=0 DO 120 III=1,5*INC IBEG=MOD(III-1,INC)+1 DO 120 I=IBEG,NTTOT,INC IF(NCOUNT(I) .GT. 0)GO TO 120 C IF(I .LE. NTDTA)THEN JLAT=TDATA(I,ILAT) IF(TDATA(I,ILON).GE. ANLON+1.)TDATA(I,ILON)= * TDATA(I,ILON)-ANLON IF(TDATA(I,ILON).LT. 1.)TDATA(I,ILON)=TDATA(I,ILON)+ANLON JLON=TDATA(I,ILON) JSIG=TDATA(I,ISIG) DX=TDATA(I,ILON)-JLON DY=TDATA(I,ILAT)-JLAT DS=TDATA(I,ISIG)-JSIG JLAT=MAX(1,MIN(JLAT,NLAT)) JSIG=MAX(1,MIN(JSIG,NSIG)) IF(ICOUNT(JLAT,JLON,JSIG) .EQ. 1)GO TO 120 JLATP=JLAT+1 JLATP=MIN(JLATP,NLAT) IF(ICOUNT(JLATP,JLON,JSIG) .EQ. 1)GO TO 120 JSIGP=JSIG+1 JSIGP=MIN(JSIGP,NSIG) IF(ICOUNT(JLAT,JLON,JSIGP) .EQ. 1)GO TO 120 IF(ICOUNT(JLATP,JLON,JSIGP) .EQ. 1)GO TO 120 JLONP=JLON+1 IF(JLONP .GT. NLON)JLONP=JLONP-NLON IF(ICOUNT(JLATP,JLONP,JSIGP) .EQ. 1)GO TO 120 IF(ICOUNT(JLATP,JLONP,JSIG) .EQ. 1)GO TO 120 IF(ICOUNT(JLAT,JLONP,JSIGP) .EQ. 1)GO TO 120 IF(ICOUNT(JLAT,JLONP,JSIG) .EQ. 1)GO TO 120 ICOUNT(JLAT,JLON,JSIG)=1 ICOUNT(JLAT,JLONP,JSIG)=1 ICOUNT(JLATP,JLON,JSIG)=1 ICOUNT(JLATP,JLONP,JSIG)=1 ICOUNT(JLAT,JLON,JSIGP)=1 ICOUNT(JLAT,JLONP,JSIGP)=1 ICOUNT(JLATP,JLON,JSIGP)=1 ICOUNT(JLATP,JLONP,JSIGP)=1 JL(I128,1)=JLAT JL(I128,2)=JLON JL(I128,3)=JSIG JL(I128,4)=JLATP JL(I128,5)=JLONP JL(I128,6)=JSIGP IF(JLAT .LE. NLTH)TDATA(I,IER)=TDATA(I,IER)*FACTOR TDATA(I,IER)=SQRT(TDATA(I,IER)) C-----------------------------------GROSS ERROR TEST ADDED HERE OBSERROR=1./MAX(TDATA(I,IER),1.E-10) OBSERRLM=MAX(ERMIN,MIN(ERMAX,OBSERROR)) RESIDUAL=ABS(TDATA(I,ITRES)) RATIO=RESIDUAL/OBSERRLM IF(OBSERROR.LT.1.E5) OBERMAX=MAX(OBERMAX,OBSERROR) OBERMIN=MIN(OBERMIN,OBSERROR) RESMAX=MAX(RESMAX,RESIDUAL) RATMAX=MAX(RATMAX,RATIO) IF(RATIO.GT.GROSS) THEN NUMGROSS=NUMGROSS+1 TDATA(I,IER)=0. END IF VAL=TDATA(I,IER)*TDATA(I,ITRES) WGT000=TDATA(I,IER)*(1.0-DX)*(1.0-DY)*(1.0-DS) WGT010=TDATA(I,IER)*DX*(1.0-DY)*(1.0-DS) WGT100=TDATA(I,IER)*(1.-DX)*DY*(1.0-DS) WGT110=TDATA(I,IER)*DX*DY*(1.0-DS) WGT001=TDATA(I,IER)*(1.-DX)*(1.-DY)*DS WGT011=TDATA(I,IER)*DX*(1.-DY)*DS WGT101=TDATA(I,IER)*(1.-DX)*DY*DS WGT111=TDATA(I,IER)*DX*DY*DS TFILE(IS)=JLAT+.001 TFILE(IS+1)=JLON+.001 TFILE(IS+2)=JSIG+.001 TFILE(IS+3)=JLATP+.001 TFILE(IS+4)=JLONP+.001 TFILE(IS+5)=JSIGP+.001 TFILE(IS+6)=WGT000 TFILE(IS+7)=WGT100 TFILE(IS+8)=WGT010 TFILE(IS+9)=WGT110 TFILE(IS+10)=WGT001 TFILE(IS+11)=WGT101 TFILE(IS+12)=WGT011 TFILE(IS+13)=WGT111 TFILE(IS+14)=TDATA(I,ITRES) TFILE(IS+15)=TDATA(I,IER) C TFILE(IS+16)=TGES(I) C TFILE(IS+17)=TDATA(I,ITYPE) TPLTY(JSIG)=TPLTY(JSIG)+VAL*VAL NUMTEMPS(JSIG)=NUMTEMPS(JSIG)+1 C C INCLUDE PSEUDO-OBSERVATIONS NEAR SURFACE TO MAKE IN BALANCE C WITH SURFACE BOUNDARY CONDITIONS C I128=I128+1 NCOUNT(I)=1 NDTTOT=NDTTOT+1 NUMDAT=NUMDAT+1 IS=IS+NPP IF(I128 .EQ. 129)I128=1 IF(NUMDAT .GT. 128)THEN ICOUNT(JL(I128,1),JL(I128,2),JL(I128,3))=0 ICOUNT(JL(I128,4),JL(I128,2),JL(I128,3))=0 ICOUNT(JL(I128,1),JL(I128,5),JL(I128,3))=0 ICOUNT(JL(I128,4),JL(I128,5),JL(I128,3))=0 ICOUNT(JL(I128,1),JL(I128,2),JL(I128,6))=0 ICOUNT(JL(I128,4),JL(I128,2),JL(I128,6))=0 ICOUNT(JL(I128,1),JL(I128,5),JL(I128,6))=0 ICOUNT(JL(I128,4),JL(I128,5),JL(I128,6))=0 END IF 120 CONTINUE 121 CONTINUE TFILE(ISSAVE)=NUMDAT+.001 NRECS=NRECS+1 IF(NDTTOT .EQ. NTTOT)GO TO 201 200 CONTINUE 201 TMPLTY=0. DO 251 K=1,NSIG NTOT=NTOT+NUMTEMPS(K) TMPLTY=TMPLTY+TPLTY(K) WRITE(6,240)NUMTEMPS(K),K,TPLTY(K) 240 FORMAT(' THERE ARE ',I9,' TEMPS AT LEVEL ',I3,' PEN = ',E12.4) 251 CONTINUE PRINT *,' TOTAL NUMBER OF NOSAT TEMPS=',NTOT WRITE(6,950)TMPLTY 950 FORMAT(' TOTAL T OBS PENALTY=',E12.4,E12.4) NTRECS=NRECS C PRINT *,NPP,NTDTA WRITE(6,*)' GROSS ERROR CHECK FOR TEMPS:' WRITE(6,*)' OBS ERROR MAX,MIN=',OBERMAX,OBERMIN WRITE(6,*)' FOR CHECK, OBS ERROR BOUNDED BY ',ERMIN,ERMAX WRITE(6,*)' FOR CHECK, MAX RATIO RESIDUAL/OB ERROR =',GROSS WRITE(6,*)' MAX RESIDUAL=',RESMAX WRITE(6,*)' MAX RATIO=',RATMAX WRITE(6,*)' NUMBER OBS THAT FAILED GROSS TEST = ',NUMGROSS RETURN END