!-------------------------------------- LICENCE BEGIN ------------------------------------
!Environment Canada - Atmospheric Science and Technology License/Disclaimer,
! version 3; Last Modified: May 7, 2008.
!This is free but copyrighted software; you can use/redistribute/modify it under the terms
!of the Environment Canada - Atmospheric Science and Technology License/Disclaimer
!version 3 or (at your option) any later version that should be found at:
!http://collaboration.cmc.ec.gc.ca/science/rpn.comm/license.html
!
!This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
!without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
!See the above mentioned License/Disclaimer for more details.
!You should have received a copy of the License/Disclaimer along with this software;
!if not, you can write to: EC-RPN COMM Group, 2121 TransCanada, suite 500, Dorval (Quebec),
!CANADA, H9P 1J3; or send e-mail to service.rpn@ec.gc.ca
!-------------------------------------- LICENCE END --------------------------------------
!
SUBROUTINE SUTOVST(TOVERRST),21
#if defined (DOC)
*
***s/r SUTOVST - Read the observation error statistics and
* utilization flag for TOVS processing.
*
*
*Author : J. Halle *CMDA/AES May 08, 1996
*
*Revision 01 : J. Halle *CMDA/AES Oct 1999
* - change file name to stats_tovs
*
*Revision 002 : J. Halle *CMDA/AES dec 2000
* adapt to TOVS level 1b.
*
*Revision 003 : J. Halle *CMDA/SMC may 2002
* adapt to RTTOV-7.
*
*Revision 004 : J. Halle *CMDA/SMC sept 2006
* adapt to RTTOV-8.
*
*Revision 005 : A. Beaulne *CMDA/SMC fevr 2007
* adapt utilization flag for AIRS channels
*
*Revision 006 : S. Heilliette
* adapt utilization flag for IASI channels
*
*Revision 007: S. Macpherson ARMA, Feb 2013
* - add NPP/ATMS codtyp=192
*Revision 008 : S. Macpherson apr 2013
* - adapt for new-format stats_tovs file
*
* -------------------
** Purpose: Read the observation error statistics and
* utilization flag for TOVS processing. This information
* resides on an ASCII file and is read using a free format.
#endif
use topLevelControl_mod
use hir_chans
use mpivar_mod
use tovs_nl_mod
use rmatrix_mod
use tovs_nl_mod
IMPLICIT NONE
C
INTEGER IER, ILUTOV, JI, JJ, JK, JL, JM, I
INTEGER IPOS1, IPOS2
INTEGER INUMSAT, ISAT, IPLF
INTEGER FNOM, FCLOS, ISRCHEQ
INTEGER IPLATFORM (JPNSATMAX)
INTEGER ISATID (JPNSATMAX)
INTEGER IINSTRUMENT (JPNSATMAX)
INTEGER IUTILST (JPCHMAX,JPNSATMAX)
INTEGER ICHN (JPCHMAX,JPNSATMAX)
INTEGER ICHNIN (JPCHMAX,JPNSATMAX)
INTEGER NUMCHN (JPNSATMAX)
INTEGER NUMCHNIN (JPNSATMAX)
*
REAL*8 TOVERRIN(JPCHMAX,2,JPNSATMAX)
REAL*8 TOVERRST(JPCHMAX,JPNSATMAX)
REAL ZDUM
C
CHARACTER*132 CLDUM
CHARACTER*132 CPLATF
CHARACTER*132 CINSTR
C
EXTERNAL FNOM, FCLOS, ISRCHEQ
EXTERNAL ABORT3D
C
WRITE(*,FMT=9000)
9000 FORMAT(//,10x,"-SUTOVST: reading observation error statistics"
S ," required for TOVS processing")
C
C
C* 1. Initialize
C . ----------
C
100 CONTINUE
DO JL = 1, JPNSATMAX
DO JI = 1, JPCHMAX
TOVERRST(JI,JL) = 0.0D0
TOVERRIN(JI,1,JL) = 0.0D0
TOVERRIN(JI,2,JL) = 0.0D0
IUTILST (JI,JL) = 0
ENDDO
ENDDO
*
DO JL = 1, JPNSATMAX
IPLATFORM(JL) = 0
NUMCHN(JL) = 0
NUMCHNIN(JL) = 0
DO JI = 1, JPCHMAX
ICHN(JI,JL) = 0
ICHNIN(JI,JL) = 0
ENDDO
ENDDO
if (nobtov==0) return
C
C* 2. Open the file
C . -------------
C
200 CONTINUE
ilutov = 0
IER = FNOM(ILUTOV,'stats_tovs','SEQ+FMT',0)
IF(IER.LT.0)THEN
WRITE ( *, '(" SUTOVST: Problem opening ","file stats_tovs ")' )
CALL ABORT3D ('SUTOVST ')
END IF
C
C* 3. Print the file contents
C . -----------------------
C
300 CONTINUE
C
IF(MPI_MYID.EQ.0) THEN
WRITE(*,'(20X,"ASCII dump of stats_tovs file: "//)')
DO JI = 1, 9999999
READ (ILUTOV,'(A)',ERR=900,END=400) CLDUM
WRITE(*,'(A)') CLDUM
ENDDO
ENDIF
C
C* 4. Read number of satellites
C . ----------------------------------------------------
C
400 CONTINUE
C
REWIND(ILUTOV)
READ (ILUTOV,*,ERR=900)
READ (ILUTOV,*,ERR=900) INUMSAT
READ (ILUTOV,*,ERR=900)
C
C* 5. Read the satellite identification, the number of channels,
C* . the observation errors and the utilization flags
C . ----------------------------------------------------------
C
500 CONTINUE
C
WRITE(*,'(5X,"SUTOVST: Reading stats_tovs file: "//)')
DO JL = 1, INUMSAT
READ (ILUTOV,*,ERR=900)
READ (ILUTOV,'(A)',ERR=900) CLDUM
WRITE(*,'(A)') CLDUM
CINSTR=CLDUM
call split(CINSTR," ",CPLATF)
Write(*,*) "CINSTR: ",CINSTR
Write(*,*) "CPLATF: ",CPLATF
READ (ILUTOV,*,ERR=900)
READ (ILUTOV,*,ERR=900) ISATID(JL), NUMCHNIN(JL)
c WRITE ( *, '(" ISATID, NUMCHNIN = ",2(1X,I4))' )
c S ISATID(JL), NUMCHNIN(JL)
DO JI = 1, 3
READ (ILUTOV,*,ERR=900)
ENDDO
C
IPLATFORM(JL) = -1
DO I = 1, MXPLATFORM
IPOS1=LEN_TRIM(CPLATFORM(I))
IPOS2 = INDEX(CPLATF,CPLATFORM(I)(1:IPOS1))
IF ( IPOS2 .NE. 0 ) THEN
IPLATFORM(JL) = NOPLATFORM(I)
c WRITE ( *, '(" IPLATFORM = ",1X,I4)' )
c S IPLATFORM(JL)
GO TO 510
ENDIF
ENDDO
IF ( IPLATFORM(JL) .EQ. -1 ) THEN
WRITE ( *, '(" SUTOVST: Unknown platform!"/)' )
CALL ABORT3D ('SUTOVST ')
ENDIF
C
510 CONTINUE
IINSTRUMENT(JL) = -1
DO I = 1, MXINSTR
IPOS1=LEN_TRIM(CINSTRUMENT(I))
IPOS2 = INDEX(CINSTR,CINSTRUMENT(I)(1:IPOS1))
IF ( IPOS2 .NE. 0 ) THEN
IINSTRUMENT(JL) = NOINSTRUMENT(I)
c WRITE ( *, '(" IINSTRUMENT = ",1X,I4)' )
c S IINSTRUMENT(JL)
c s.m. 2012: needed to comment out next line to detect "SSMIS" rather than "SSMI"
c GO TO 520
ENDIF
ENDDO
IF ( IINSTRUMENT(JL) .EQ. -1 ) THEN
WRITE ( *, '(" SUTOVST: Unknown instrument!"/)' )
CALL ABORT3D ('SUTOVST ')
ENDIF
C
520 CONTINUE
DO JI = 1, NUMCHNIN(JL)
READ (ILUTOV,*,ERR=900) ICHNIN(JI,JL),
S TOVERRIN(ICHNIN(JI,JL),1,JL),
S TOVERRIN(ICHNIN(JI,JL),2,JL),
S IUTILST (ICHNIN(JI,JL),JL),ZDUM
ENDDO
READ (ILUTOV,*,ERR=900)
ENDDO
C
C** Select input error to use: if ANAL mode, use ERRANAL (JJ=2);
C* otherwise use ERRBGCK (JJ=1)
C
IF ( top_AnalysisMode() ) THEN
JJ = 2
ELSE
JJ = 1
ENDIF
c
c** Fill the observation error array TOVERRST
c
WRITE(*,'(5X,"SUTOVST: Fill error array TOVERRST: "//)')
DO JM= 1, INUMSAT
DO JL = 1, NSENSORS
c WRITE(*,*) PLATFORM (JL), ' ', IPLATFORM(JM)
c WRITE(*,*) SATELLITE(JL), ' ', ISATID (JM)
c WRITE(*,*) INSTRUMENT (JL), ' ', IINSTRUMENT(JM)
c WRITE(*,*) NUMCHNIN(JM)
IF ( PLATFORM (JL) .EQ. IPLATFORM(JM) .AND.
S SATELLITE(JL) .EQ. ISATID (JM) ) THEN
IF ( INSTRUMENT (JL) .EQ. IINSTRUMENT(JM) ) THEN
NUMCHN(JL)=NUMCHNIN(JM)
DO JI = 1, JPCHMAX
TOVERRST(JI,JL) = TOVERRIN(JI,JJ,JM)
ICHN(JI,JL) = ICHNIN(JI,JM)
ENDDO
IF (top_AnalysisMode().and.rmat_lnondiagr) call rmat_setFullRMatrix ( TOVERRST(:,JL), JL, chanoffset(JL) )
ENDIF
ENDIF
ENDDO
ENDDO
C
C** Check that oberservation error statistics have been defined for
C* all the satellites specified in the namelist.
C
DO JL = 1, NSENSORS
IPLF = ISRCHEQ ( IPLATFORM , INUMSAT, PLATFORM (JL) )
ISAT = ISRCHEQ ( ISATID , INUMSAT, SATELLITE (JL) )
IF ( IPLF .EQ. 0 .OR. ISAT .EQ. 0 ) THEN
WRITE ( *, '(" SUTOVST: Observation errors not ","defined for sensor # ", I3)' ) JL
CALL ABORT3D ('SUTOVST ')
END IF
IF ( NUMCHN(JL) .EQ. 0 ) THEN
WRITE ( *, '(" SUTOVST: Problem setting errors ","for sensor # ", I3)' ) JL
CALL ABORT3D ('SUTOVST ')
ENDIF
ENDDO
C
C** Utilization flag for AIRS,IASI and CrIS channels (bgck mode only)
C
IF ( top_BgckIrMode() ) THEN
DO JM= 1, INUMSAT
IF ( IPLATFORM(JM) .EQ. 9 .AND.
& IINSTRUMENT(JM) .EQ. 11 ) THEN
call hir_set_assim_chan("AIRS",IUTILST(ICHNIN(1:NUMCHNIN(JM),JM),JM))
END IF
IF ( IPLATFORM(JM) .EQ. 10 .AND.
& IINSTRUMENT(JM) .EQ. 16 ) THEN
call hir_set_assim_chan("IASI",IUTILST(ICHNIN(1:NUMCHNIN(JM),JM),JM))
END IF
IF ( IPLATFORM(JM) .EQ. 17 .AND.
& IINSTRUMENT(JM) .EQ. 27 ) THEN
call hir_set_assim_chan("CRIS",IUTILST(ICHNIN(1:NUMCHNIN(JM),JM),JM))
END IF
ENDDO
END IF
C
C* 6. Print out observation errors for each sensor
C . --------------------------------------------
C
600 CONTINUE
C
IF(MPI_MYID.eq.0) THEN
WRITE(*,'(//1X,"Radiance observation errors read from file")')
WRITE(*,'( 1X,"------------------------------------------")')
DO JL = 1, NSENSORS
WRITE(*,'(/1X,"SENSOR #",I2,". Platform: ",A,"Instrument: ",A)')
& JL, CSATID(JL), CINSTRUMENTID(JL)
WRITE(*,'(1X,"Channel",5X," error ")')
DO JI = 1, NUMCHN(JL)
WRITE (*,'(1X,I7,1(5X,F10.2))') ICHN(JI,JL),
& TOVERRST(ICHN(JI,JL),JL)
ENDDO
ENDDO
ENDIF
C
C* 7. Close the file
C . --------------
C
700 CONTINUE
C
IER = FCLOS(ILUTOV)
IF(IER.NE.0)THEN
CALL ABORT3D ('SUTOVST ')
END IF
RETURN
C
C* Read error
C
900 WRITE ( *, '(" SUTOVST: Problem reading ","file stats_tovs ")' )
CALL ABORT3D ('SUTOVST ')
C
RETURN
contains
subroutine compact(str) 2
C Code from Benthien's module: http://www.gbenthien.net/strings/index.html
C Converts multiple spaces and tabs to single spaces; deletes control characters;
C removes initial spaces.
character(len=*):: str
character(len=1):: ch
character(len=len_trim(str)):: outstr
integer isp,k,lenstr,i,ich
str=adjustl(str)
lenstr=len_trim(str)
outstr=' '
isp=0
k=0
do i=1,lenstr
ch=str(i:i)
ich=iachar(ch)
select case(ich)
C space or tab character
case(9,32)
if(isp==0) then
k=k+1
outstr(k:k)=' '
end if
isp=1
C not a space, quote, or control character
case(33:) ! not a space, quote, or control character
k=k+1
outstr(k:k)=ch
isp=0
end select
end do
str=adjustl(outstr)
end subroutine compact
subroutine split(str,delims,before) 2,2
C Code extracted from Benthien's module: http://www.gbenthien.net/strings/index.html
C Routine finds the first instance of a character from 'delims' in the
C the string 'str'. The characters before the found delimiter are
C output in 'before'. The characters after the found delimiter are
C output in 'str'.
character(len=*) :: str,delims,before
character :: ch,cha
integer lenstr,i,k,ipos,iposa
str=adjustl(str)
call compact(str)
lenstr=len_trim(str)
C string str is empty
if(lenstr == 0) return
k=0
before=' '
do i=1,lenstr
ch=str(i:i)
ipos=index(delims,ch)
C character is not a delimiter
if(ipos == 0) then
k=k+1
before(k:k)=ch
cycle
end if
C character is a delimiter that is not a space
if(ch /= ' ') then
str=str(i+1:)
exit
end if
C character is a space delimiter
cha=str(i+1:i+1)
iposa=index(delims,cha)
C next character is a delimiter
if(iposa > 0) then
str=str(i+2:)
exit
else
str=str(i+1:)
exit
end if
end do
if(i >= lenstr) str=''
C remove initial spaces
str=adjustl(str)
return
end subroutine split
END