SUBROUTINE ch_diagn(ctype) 2,2
C
#if defined (DOC)
*
***s/r CH_DIAGN
*
*Author : Y.J. Rochon ARQX, March 2010
*Revision:
*
** Purpose: Produce and output layer dependent diagnostics for TR subfamilies
*
*Arguments
*
* Input:
*
* ctype 'OmP' or 'OmA'
*
#endif
IMPLICIT NONE
C
character*(*) ctype
C
C Global variables
C
#include "pardim.cdk"
#include "comdim.cdk"
#include "comdimo.cdk"
#include "comgem.cdk"
#include "comnumbr.cdk"
#include "comoabdy.cdk"
#include "comoahdr.cdk"
#include "comoba.cdk"
#include "comchem.cdk"
#include "comstate.cdk"
#include "commvo.cdk"
#include "commvog.cdk"
#include "commvohr.cdk"
#include "cvcord.cdk"
#include "comlun.cdk"
C
C Declaration of local variables
C
INTEGER IOBS,IPOS,I2
INTEGER JDATA,J,IBEGIN,ILAST,ITRCODE
INTEGER IOBSNMB, IOBSTYP,IOBSLEV,IIFLAG
INTEGER JOBS, IDATA, IDATEND
INTEGER IBEGIN1, ILAST1
INTEGER JLT,ILMAX,INUMS,INUM
INTEGER IDIM
PARAMETER (IDIM=500)
REAL*8 ZOBSLEV(IDIM),ZOBSLEV2(IDIM),ZVTR(JPNFLEV)
REAL*8 zrcpps,zptop,zoer,zlat,zlon
C
INTEGER nprof(ncmtmax),icount
INTEGER CH_KGETPOS
EXTERNAL CH_KGETPOS
C
INTEGER J1,J2
REAL*8 RMEAN1,RMEAN2,RMEAN3
C
CHARACTER*10 CNAME
C First, calc sums for diagnostics
C
C Initialization
C
nprof(:)=0
ntrcount(:,:)=0
rtromap(1:2,:,:)=0.0
rtromap(4,:,:)=0.0
if (CTYPE.eq.'OmP'.or.CTYPE.eq.'OMP') rtromap(3,:,:)=0.0
C
C Note on loops:
C
C J: 1 to NFILES : Obs family counter for CMA data arrays
C JOBS: IBEGIN1 to ILAST1 : Obs report counter within family
C J1: 1 to INUM : Obs (profile) counter within report
C INUM=1 for report with single obs profile.
C
C* Loop over obs familes.
C
CNAME=' '
DO J=1,NFILES
C
C Check for target 'TR' family
C
IF (CFAMTYP(J).EQ.'TR'.AND.NBEGINTYP(J).GT.0.AND.
1 NENDTYP(J).GE.NBEGINTYP(J)) THEN
C
C Identify range of observation reports
C
IBEGIN=NBEGINTYP(J)
ILAST=NENDTYP(J)
IBEGIN1 = MOBDATA(NCMOBS,IBEGIN)
ILAST1 = MOBDATA(NCMOBS,ILAST)
C
C Loop over obs reports in a subfamily
C
DO JOBS = IBEGIN1, ILAST1
C
C Loop over obs (profiles) in a report.
C
INUM=MOBHDR(NCMNUM,JOBS)
INUMS=MOBHDR(NCMNLV,JOBS)
DO J1=1,INUM
C
C Identify range of elements for an obs in the report
C
IF (J1.EQ.1) THEN
IDATA = MOBHDR(NCMRLN,JOBS)
IF (INUM.GT.1) INUMS=MOBDATA(NCMNUM1,IDATA)
IDATEND = INUMS + IDATA - 1
ELSE
IDATA=IDATA+INUMS
IF (INUM.GT.1) INUMS=MOBDATA(NCMNUM1,IDATA)
IDATEND=INUMS+IDATA-1
END IF
C
C Check observation vertical coordinate and convert
C to pressure when necessary.
C
CALL CH_VOBS_TO_P(NULOUT,JOBS,ZOBSLEV,ZOBSLEV2,
1 IDATA,IDATEND,IOBSLEV,IDIM,IIFLAG)
IF (IIFLAG.NE.0.OR.IOBSLEV.NE.INUMS) THEN
write(nulout,*) 'CH_DIAGN: Level inconsistency.'
goto 150
END IF
C
C Obtain obs type info.
C
IOBSTYP = MOBDATA(NCMCORD1,IDATA)
IF (IOBSTYP.NE.1.AND.IOBSTYP.NE.2.AND.
& IOBSTYP.NE.3.AND.IOBSTYP.NE.4) GO TO 150
C
IOBSNMB = MOBDATA(NCMVNM,IDATA)
IOBS = MOBDATA(NCMOBS,IDATA)
IPOS = MOBDATA(NCMPOS,IDATA)
ITRCODE = MOBDATA(NCMSPEC,IDATA)
C
JLT = CH_KGETPOS(IOBSNMB, ITRCODE, CSTNID(JOBS))
IF (JLT .LT. 0) THEN
write(nulout, *) 'Species ', IOBSNMB, ' not processed!'
write(nulout,*) ITRCODE,CSTNID(JOBS),JOBS
go to 150
END IF
C
C If obs vertical coordinate not in pressure, save derived
C pressures in ROBDATA(NCMPPX,*). For storage in BURP files.
C
IF (MOBDATA(NCMVCO,IDATA) .EQ. 1) THEN
IF (IOBSTYP.EQ.1) THEN
ROBDATA(NCMPPX,IDATA:IDATEND)=zobslev(1:INUMS)
ELSE
ROBDATA(NCMPPX,IDATA:IDATEND)=sqrt(zobslev(1:INUMS)
& *zobslev2(1:INUMS))
END IF
END IF
C
C Obtain latitude and longitude of obs report
C
c ZLAT=ROBHDR(NCMLAT,JOBS)
c ZLON=ROBHDR(NCMLON,JOBS)
C
C* Identify background/increment arrays at obs lat/long location
C
if (CTYPE .eq. 'OmP'.or.CTYPE.eq.'OMP') then
zptop=RPPOBSHR(1,IOBS)
zrcpps = gompshr(1,iobs) ! Surface pressure
else
zptop=RPPOBS(1,IOBS)
zrcpps = gompsg(1,iobs) ! Surface pressure
end if
C
C* Accumulate OmP/var (or OmA/var) and OmP^2/var. (or OmA^2/var.)
C over diagnostic layers for output from module CH_DIAGN.
C
icount=0
if (NTRLEV(JLT).gt.0) then
DO JDATA=IDATA,IDATEND
if (MOBDATA(NCMASS,JDATA).EQ.1.and.
& MOBDATA(NCMXTR,JDATA).eq.0.and.
& MOBDATA(NCMFLG,JDATA).lt.16384) then
if (iobstyp.eq.1) then
zvtr(jdata-idata+1)=zobslev(jdata-idata+1)
else if (zobslev(jdata-idata+1).le.1.1*zptop.and.
& zobslev2(jdata-idata+1).ge.0.99*zrcpps) then
zvtr(jdata-idata+1)=rtrlev(ntrlev(jlt)+1,jlt)*0.99
else
zvtr(jdata-idata+1)=
& sqrt(max(rtrlev(1,jlt),zobslev(jdata-idata+1))
& *min(rtrlev(ntrlev(jlt)+1,jlt),zobslev2(jdata-idata+1)))
end if
do i2=1,NTRLEV(JLT)
if (zvtr(jdata-idata+1).GT.rtrlev(i2,jlt).and.
& zvtr(jdata-idata+1).LE.rtrlev(i2+1,jlt)) then
ntrcount(i2,jlt)=ntrcount(i2,jlt)+1
ZOER=1.0D0/ROBDATA8(NCMOER,JDATA)
rtromap(1,i2,jlt)=rtromap(1,i2,jlt)-
& ROBDATA8(NCMOMA,JDATA)*ZOER
rtromap(2,i2,jlt)=rtromap(2,i2,jlt)+
& ROBDATA8(NCMOMA,JDATA)*ROBDATA8(NCMOMA,JDATA)
rtromap(4,i2,jlt)=rtromap(4,i2,jlt)+
& ZOER*ZOER
C
if (CTYPE.eq.'OmP'.or.CTYPE.eq.'OMP')
& rtromap(3,i2,jlt)=rtromap(3,i2,jlt)+
& ROBDATA8(NCMVAR,JDATA)
C
icount=icount+1
exit
end if
end do
end if
END DO
end if
if (icount.gt.0) nprof(jlt)=nprof(jlt)+1
C
150 CONTINUE
END DO ! (J1)
END DO ! (JOBS)
END IF
END DO ! (NFILES)
C
C Output diagnostics to listing file.
C
C Loop over subfamilies
C
IF (NCMTASSI.EQ.0) RETURN
C
write (nulout,*) ' '
write (nulout,*) 'ENTERING CH_DIAGN: Layer dependent diagnostics for TR subfamilies'
write (nulout,*) ' '
C
DO J2=1,NCMTASSI
C
if (ntrlev(J2).eq.0) cycle
write(nulout, *) '!tr'
write(nulout, *) '!tr Subfamily: ',CNAMANAL(J2),' from ',CTRSTNID(J2),' ',NETR(J2)
write(nulout, *) '!tr Nprof: ',nprof(j2)
write(nulout, *) '!tr'
write(nulout, *) '!tr Layer N Mean Rel diff. Mean diff. 2*Jo/N '
write(nulout, *) '!tr (hPa) obs (',ctype,' %) (',ctype,')'
write(nulout, *) '!tr'
do J1=1,ntrlev(J2)
if (ntrcount(j1,j2).lt.10) cycle
if (CTYPE.eq.'OmP'.or.CTYPE.eq.'OMP') then
RMEAN1=rtromap(3,j1,j2)/ntrcount(j1,j2)
rtromap(3,j1,j2)=RMEAN1 ! for use when ctype='OmA'
else
RMEAN1=rtromap(3,j1,j2)
end if
if (abs(RMEAN1).lt.1.E-20) RMEAN1=-999.99
RMEAN2=rtromap(1,j1,j2)/rtromap(4,j1,j2)
RMEAN3=rtromap(2,j1,j2)/ntrcount(j1,j2)
if (abs(RMEAN3).gt.9999.) RMEAN3=9999.99
write(nulout,1000) rtrlev(j1,j2)/100.,rtrlev(j1+1,j2)/100.,
& ntrcount(j1,j2),RMEAN1,RMEAN2/RMEAN1*100.0,RMEAN2,RMEAN3
end do
END DO
C
1000 format(' !tr ',F8.4,'-',F9.4,1X,I6,2X,3(G10.3,2X),F7.2)
2000 format(' !tr ',F8.4,'-',F9.4,1X,I6,2X,G10.3,2X,F7.2)
write (nulout,*)
write (nulout,*) 'LEAVING CH_DIAGN'
write (nulout,*)
C
RETURN
END