!copyright (C) 2001 MSC-RPN COMM %%%RPNPHY%%%
***S/P SERIE - PROCESSEUR DE SERIES TEMPORELLES DES MODELES SEF, MC2 ET GEM
#include "phy_macros_f.h"
SUBROUTINE SERIE(INPUNIT,SERSTD,STATUS,ECHO) 1,34
#include "impnone.cdk"
INTEGER INPUNIT,SERSTD,STATUS
LOGICAL ECHO
*
*Author
* Robert Benoit(July 1984)
*
*Revision
* 001 Pierre Sarrazin(November 84)
* V1.1 Documentation
* Introduce modules CCARD,FNOM,FCLOS
* Exit error with comments
* 002 Jean Cote(February 85)
* RFE-SEF Compatible version
* Dynamic allocation of memory
* 003 V.Alex (February 87)
* Standard verification
* 004 M. Lepine - RFE model code revision project (Mar 87)
* Organization of code
* 006 J. Cote (Mar 88) Other models that SEF and FE allowed
* by decoding DGRW before ETIKET
* 005 R Benoit - Remove error due to PHYS(20,NPHYSP) when
* number of points >20 (Dec 88)
* 007 R. Benoit (Nov 89) Correction of a bug for short
* series(4 time steps)
* 008 N. Brunet (May91)
* New version of thermodynamic functions
* and file of constants
* 009 B. Bilodeau (July 1991)- Adaptation to UNIX
* 010 B. Bilodeau (August 1992)-
* Eliminate the variable DYNAM and test only
* the first letter of the label
* 011 G. Pellerin (April 1992)- Adaptation to PASTEMP
* read variables directly in vector NOMVAR
* and code clean-up for zonal diagnostics
* 012 G. Pellerin (Dec 1994) - Add 0.5 to ITYP to calculate MG
* 013 B. Bilodeau (Jan 1997) - PTOIT and ETATOIT for hybrid
* coordinates. Wind rotation for GEF.
* 014 B. Bilodeau (June 1997) - Maximum number of levels : 75.
* Maximum number of variables : 256.
* 015 S. Chamberland and B. Bilodeau (June 1997) -
* IBM32 to IEEE format conversion
* 016 B. Bilodeau (July 1998) - Automate IBM32 to IEEE conversion
* 017 B. Bilodeau (Sept 1999) - Add MG, GL and SD
* 018 B. Bilodeau (Sept 2000) - Replace MEMOIR by STKMEMW for SX5
* 019 B. Bilodeau (Jan 2001) - Allocatable arrays
* 020 B. Bilodeau (Feb 2002) - Allocate PHYSE in serie; write some
* records in E32 format instead of R32
* 021 B. Bilodeau (Jul 2002) - Optimization
*
*Object
* to process time-series of RFE and SEF models. It reads the
* sequential file generated by FEMAIN (RFE) or REXSEF (SEF)
* and reformats the data in a standard RPN file for input to
* graphic programs.
*
*Arguments
*
* - Input -
* INPUNIT unit number attached to sequential input file
* SERSTD unit number attached to standard RPN output file
*
* - Output -
* STATUS =1 if no records read
* =2 if no surface variables
* =4 if too much space is required
*
* - Input -
* ECHO .TRUE. to write out debug statements
* .FALSE. to not write debug statements
*
*
*Note
* Reference: "PASTEMP" J.Caveen October 1989
*
*parametres
*
#include "maxlev.cdk"
*
*IMPLICITES
#include "sercmdk.cdk"
*
*MODULES
*
INTEGER FSTECR
EXTERNAL FSTECR
EXTERNAL SERPAT2
EXTERNAL SERFIN
EXTERNAL SERECRI
INTEGER INDSERI
EXTERNAL INDSERI
EXTERNAL DIFUVD8
*
*NOTE
* REFERENCE: "GRAPHIQUES POUR LES DIAGNOSTIQUES PONCTUELS
* COMMUNICATION NO 6 GROUPE DU MODELE SPECTRAL" OCT 83.
**
*
* VARIABLES ALLOUEES DYNAMIQUEMENT
*
REAL , DIMENSION(:) , ALLOCATABLE:: HH, STOK, DIAG
REAL , DIMENSION(:,:) , ALLOCATABLE:: PHYSE
REAL , DIMENSION(:,:,:) , ALLOCATABLE:: SERS_T
REAL , DIMENSION(:,:,:,:) , ALLOCATABLE:: SERP_T
*
*
INTEGER TMP,AL,MG,Z0,HS,CND,LAT,LON,GL,NE,MAP,SD
CHARACTER *4 NOMVAR(NVAR), MODELE*3
*
REAL S(LEVMAX),DGRW,RGAS,GRAV
CHARACTER *8 ETIKET, ETIKMAJ
INTEGER DATE(14),NK,ITYP,NTYPES,IECR
CHARACTER *1 TV
REAL SH(LEVMAX) ,PHS
INTEGER I,K,L,M,LP,NT,NREC,NSKIP,IP2,NPAK,NPHYE,DATYP
LOGICAL SATUES, SATUCO
*
* DESCRIPTEURS DE LA GRILLE GEF
INTEGER IG(4)
*
REAL DEGRAD ,scrap
REAL ETATOIT, PTOIT, CONVERTI
LOGICAL IBM32_2_IEEE
*
*
*
REWIND INPUNIT
*
* CHAMPS PHYSIQUES INVARIANTS
*
NREC = 0
NSKIP = 3
READ ( INPUNIT , END=2 ) CONVERTI, NSTAT,
X (IJSTAT(L,1),JSTAT(L),L=1,NSTAT),
Y NPHYE,(NOMVAR(M),M=1,NPHYE),
Z NPROF,(PROFILS(M,1),M=1,NPROF),
T (DATE(K),K=1,14),ETIKET,NK,(S(K),K=1,NK),
U PTOIT, ETATOIT, (IG(K),K=1,4),
V DGRW, RGAS, GRAV, SATUES, SATUCO
*
* INITIALISATION DE LA CLE IBM32_2_IEE
IBM32_2_IEEE = .TRUE.
IF (CONVERTI.EQ.100.) THEN
IBM32_2_IEEE = .FALSE.
ENDIF
*
IF (IBM32_2_IEEE) THEN
*
PRINT *
PRINT *,'****************************************************'
PRINT *,'* CONVERSION DU FORMAT IBM 32 BITS VERS IEEE *'
PRINT *,'****************************************************'
PRINT *
*
* CONVERSION DES REELS DU FORMAT IBM 32 BITS AU FORMAT IEEE
call ibm32_ieee(S,NK)
call ibm32_ieee(PTOIT,1)
call ibm32_ieee(ETATOIT,1)
call ibm32_ieee(DGRW,1)
call ibm32_ieee(RGAS,1)
call ibm32_ieee(GRAV,1)
*
ENDIF
*
NREC = NREC + 1
WRITE ( 6 , * ) 'NSTAT = ',NSTAT
WRITE ( 6 , * ) 'IJSTAT = ',(IJSTAT(L,1),L=1,NSTAT)
WRITE ( 6 , * ) 'JSTAT = ',(JSTAT(L),L=1,NSTAT)
WRITE ( 6 , * ) 'NK = ',NK,' S = ',(S(K),K=1,NK)
WRITE ( 6 , * ) 'PTOIT = ',PTOIT,' ETATOIT = ',ETATOIT
WRITE ( 6 , * ) 'DGRW = ',DGRW,' RGAS = ',RGAS,' GRAV = ',GRAV
WRITE ( 6 , '(1X,I3,20(1X,A2))' )
Y NPHYE,(NOMVAR(M),M=1,NPHYE)
WRITE ( 6 , '(1X,I3,20(1X,A2))' )
Z NPROF,(PROFILS(M,1),M=1,NPROF)
WRITE ( 6 , '(1X,9HETIKET = ,A8)' ) ETIKET
WRITE ( 6 , 6060 ) DATE
6060 FORMAT(22H DATE-TIME GROUP ,2X,6I6,6A4,A1,I12)
*
WRITE(6,612)SATUES,SATUCO
612 FORMAT(/,10X,'SATUES,SATUCO=',2(L1,2X),/)
*
*--------------------------------------------------------------------
*
* ALLOCATE ARRAY PHYSE
ALLOCATE ( PHYSE(NSTAT,NPHYE) )
*
READ ( INPUNIT , END=2 ) HEURE,((PHYSE(L,M),L=1,NSTAT),M=1,NPHYE)
*
* CONVERSION DES REELS DU FORMAT IBM 32 BITS AU FORMAT IEEE
IF (ibm32_2_ieee) THEN
call ibm32_ieee(HEURE,1)
call ibm32_ieee(PHYSE,MXSTT*NPHYE)
ENDIF
NREC = NREC + 1
WRITE ( 6 , * ) HEURE,((PHYSE(L,M),L=1,NSTAT),M=1,NPHYE)
*
* TROUVER LE NOMBRE DE PAS DE TEMPS SAUVES
*
1 READ ( INPUNIT , END=2 )
NREC = NREC + 1
GO TO 1
2 NT = NREC - NSKIP
IF ( NT.LE.0 ) THEN
STATUS = 1
RETURN
ENDIF
*
* POINTEURS DES CHAMPS PHYSIQUES
*
IF ( NPHYE .LE. 0 ) THEN
PRINT *,'NPHYE = ',NPHYE
STATUS = 2
RETURN
ELSE
*
MAP=indseri('MA',nomvar,nphye)
LAT=indseri('LA',nomvar,nphye)
LON=indseri('LO',nomvar,nphye)
NE=indseri('NE',nomvar,nphye)
GL=indseri('GL',nomvar,nphye)
MG=indseri('MG',nomvar,nphye)
HS=indseri('HS',nomvar,nphye)
Z0=indseri('ZP',nomvar,nphye)
AL=indseri('AL',nomvar,nphye)
TMP=indseri('TM',nomvar,nphye)
CND=indseri('TP',nomvar,nphye)
SD=indseri('SD',nomvar,nphye)
*
ENDIF
*
* VERIFIER SI CERTAINS CHAMPS MANQUENT
*
*
* CHARGER L'ENTETE
*
REWIND INPUNIT
DO 5 I=1,NSKIP-1
5 READ ( INPUNIT )
*
READ ( INPUNIT ) CONVERTI, NSTAT,
X (IJSTAT(L,1),JSTAT(L),L=1,NSTAT),
Y NSURF,(SURFACE(M,1),M=1,NSURF),
Z NPROF,(PROFILS(M,1),M=1,NPROF),
T (DATE(K),K=1,14),ETIKET,NK,(S(K),K=1,NK),
U PTOIT, ETATOIT, (IG(K),K=1,4),
V DGRW, RGAS, GRAV, SATUES, SATUCO
*
* CONVERSION DES REELS DU FORMAT IBM 32 BITS AU FORMAT IEEE
IF (ibm32_2_ieee) THEN
call ibm32_ieee(S,NK)
call ibm32_ieee(PTOIT,1)
call ibm32_ieee(ETATOIT,1)
call ibm32_ieee(DGRW,1)
call ibm32_ieee(RGAS,1)
call ibm32_ieee(GRAV,1)
ENDIF
*
WRITE ( 6 , * ) 'NSTAT = ',NSTAT
WRITE ( 6 , * ) 'IJSTAT = ',(IJSTAT(L,1),L=1,NSTAT)
WRITE ( 6 , * ) 'JSTAT = ',(JSTAT(L),L=1,NSTAT)
WRITE ( 6 , * ) 'NK = ',NK,' ETA = ',(S(K),K=1,NK)
WRITE ( 6 , * ) 'PTOIT = ',PTOIT,' ETATOIT = ',ETATOIT
WRITE ( 6 , * ) 'DGRW = ',DGRW,' RGAS = ',RGAS,' GRAV = ',GRAV
WRITE ( 6 , '(1X,I3,20(1X,A2))' )
Y NSURF,(SURFACE(M,1),M=1,NSURF)
WRITE ( 6 , '(1X,I3,20(1X,A2))' )
Z NPROF,(PROFILS(M,1),M=1,NPROF)
WRITE ( 6 , '(1X,9HETIKET = ,A8)' ) ETIKET
WRITE ( 6 , 6060 ) DATE
*
WRITE ( 6 , 6060 ) DATE
*
* VERIFICATION DE L'ETIQUETTE
*
* CONVERSION DE L'ETIQUETTE EN MAJUSCULES
CALL LOW2UP(ETIKET,ETIKMAJ)
*
IF ( ETIKMAJ(1:1) .EQ. 'S' ) THEN
*
MODELE = 'SEF'
WRITE ( 6 , * ) 'MODELE SEF'
*
ELSE IF ( ETIKMAJ(1:1) .EQ. 'F' ) THEN
*
MODELE = 'EFR'
WRITE ( 6 , * ) 'MODELE EFR'
*
ELSE IF ( ETIKMAJ(1:1) .EQ. 'G' ) THEN
*
MODELE = 'GEF'
WRITE ( 6 , * ) 'MODELE GEF'
*
ELSE
*
* PAR DEFAUT, PAS DE ROTATION POUR LES AUTRES MODELES
*
ENDIF
*
* ALLOUER LA MEMOIRE
*
ALLOCATE ( HH(NT) )
ALLOCATE ( STOK(NT*NK) )
ALLOCATE ( DIAG(NT*NK) )
ALLOCATE ( SERS_T(NT,NSURF,NSTAT) )
ALLOCATE ( SERP_T(NK,NT,NPROF,NSTAT) )
*
*
* CHERCHER LES HEURES
*
REWIND INPUNIT
DO 6 I=1,NSKIP
6 READ ( INPUNIT )
DO 7 I=1,NT
READ ( INPUNIT) HH(I)
*
* CONVERSION DES REELS DU FORMAT IBM 32 BITS AU FORMAT IEEE
IF (ibm32_2_ieee) THEN
call ibm32_ieee(HH(I),1)
ENDIF
*
7 continue
WRITE ( 6 , * ) 'HEURES = ',(HH(I),I=1,NT)
*
* AJOUTER L'HEURE INITIALE
*
DO 8 I=1,NT
8 HH (I) = HH (I) + DATE(5)
WRITE ( 6 , * ) 'HEURES = ',(HH(I),I=1,NT)
*
* ECRIRE TROIS RECORDS A SERSTD POUR HEURES ET NIVEAUX
* conformement a pastemp
*
TV='T'
NPAK=-32
DATYP=5
IP2 =FLOAT(DATE(5))*100
IECR = FSTECR(HH,STOK,NPAK,SERSTD,DATE(14),0,0,NT,1,1,
1 0,0,0,TV,'HH',ETIKET,'T',0,0,0,0,DATYP,.TRUE.)
IECR = FSTECR(S ,STOK,NPAK,SERSTD,DATE(14),0,0,NK,1,1,
1 0,0,0,TV,'SV',ETIKET,'T',0,0,0,0,DATYP,.TRUE.)
*
* CALCULER LES NIVEAUX CENTRES (OPTION STAGE)
*
CALL DIFUVD8 (SH, .TRUE., S, NK, NK-1)
*
IECR = FSTECR(SH,STOK,NPAK,SERSTD,DATE(14),0,0,NK,1,1,
1 0,0,0,TV,'SH',ETIKET,'T',0,0,0,0,DATYP,.TRUE.)
*
*-----------------------------------------------------------------
*
DEGRAD = ACOS ( -1.0 )/180.0
*
*
REWIND INPUNIT
DO 9 K=1,NSKIP
9 READ ( INPUNIT ) scrap
*
DO 10 I=1,NT
*
READ ( INPUNIT ) HEURE,((SERS(LP,M),LP=1,NSTAT),M=1,NSURF),
X (((SERP(K,LP,M),K=1,NK),LP=1,NSTAT),M=1,NPROF)
*
IF (ibm32_2_ieee) THEN
call ibm32_ieee(HEURE,1)
c call ibm32_ieee(SERS,MXSTT*MXSRF)
call ibm32_ieee(SERS,MXSTT*NSURF)
c call ibm32_ieee(SERP,MXNVO*MXSTT*MXPRF)
call ibm32_ieee(SERP,MXNVO*MXSTT*NPROF)
ENDIF
*
IF (ECHO) THEN
WRITE (6,*) ' HEURE=',HEURE
DO L=1,NSTAT
WRITE (6,*) ' STATION NO.',L
WRITE (6,*) ' SURFACES=',(SERS(L,M),M=1,NSURF)
DO 20 M=1,NPROF
20 WRITE (6,*) ' PROFIL NO.=',M,' ',(SERP(K,L,M),K=1,NK)
END DO
ENDIF
*
* TRANSFERER SERIES DE POINTS A TEMPS
* TRANSFERER SERIES DE POINTS A TEMPS
*
CALL SERPAT2 ( SERS_T , SERP_T , I , NT , NK ,
+ NSURF, NPROF, NSTAT )
*
*
10 CONTINUE
*
*
DO 100 L=1,NSTAT
*
* BOUCLE SUR LES POINTS (DO 100)
* L=POINT, I=TEMPS
*
* FINALISER LES SERIES EN TEMPS
*
CALL SERFIN ( SERS_T(1,1,L) , SERP_T(1,1,1,L) , SURFACE , PROFILS ,
1 NT , NK , NSURF , NPROF ,
2 DGRW , PHYSE(L,MAP) , PHYSE(L,LAT), PHYSE(L,LON),
3 DEGRAD, MODELE, IG)
*
* ECRIRE SERIES POUR CE POINT SUR SERSTD
*
CALL SERECRI(SERS_T(1,1,L),SERP_T(1,1,1,L),SERSTD,NSURF,
1 NPROF,NT,SURFACE,PROFILS,L,PHYSE(L,LAT),PHYSE(L,LON),
2 STOK, S, PTOIT, ETATOIT, DIAG, DATE(14), ETIKET,
3 FLOAT(DATE(5)), NK, SATUES, SATUCO)
*
*
*
100 CONTINUE
*
*
IECR = FSTECR (PHYSE(1,MG),STOK,NPAK,serstd,date(14),0,0,NSTAT,
1 1,1,0,IP2,0,TV,'MG',ETIKET,'Y',0,IP2,0,0,DATYP,.FALSE.)
*
* CARACTERISTIQUES DU SOL DANS TEMPORAIRES POUR STOCKAGE
*
DO 110 l=1,NSTAT
*
ITYP=PHYSE(L,MG) + 0.5
IF (ITYP.LE.0) THEN
PHS=PHYSE(L,GL)
ELSE
PHS=PHYSE(L,HS)
IF (PHS .LT. 0) PHS = 0
ENDIF
PHYSE(L,HS)=PHS
*
IF(ITYP.LE.0) THEN
IF(PHYSE(L,GL).LT.0.9) THEN
NTYPES=0
ELSE
NTYPES=2
ENDIF
ELSE IF(ITYP.GE.1) THEN
IF(PHYSE(L,NE).GT.0.) THEN
NTYPES=1
ELSE
NTYPES=-1
ENDIF
ENDIF
PHYSE(L,MG)=NTYPES
PHYSE(L,TMP)=PHYSE(L,TMP)-273.15
PHYSE(L,Z0)=MAX(0.,PHYSE(L,Z0))
*
110 CONTINUE
*
* ECRITURE DES ENREGISTREMENTS SUR serstd
*
*
IECR = FSTECR (PHYSE(1,LAT),STOK,NPAK,serstd,date(14),0,0,NSTAT,
1 1,1,0,IP2,0,TV,'^^',ETIKET,'T',0,0,0,0,DATYP,.FALSE.)
*
IECR = FSTECR (PHYSE(1,LON),STOK,NPAK,serstd,date(14),0,0,NSTAT,
1 1,1,0,IP2,0,TV,'>>',ETIKET,'T',0,0,0,0,DATYP,.FALSE.)
*
IECR = FSTECR (PHYSE(1,MG),STOK,NPAK,serstd,date(14),0,0,NSTAT,
1 1,1,0,IP2,0,TV,'GS',ETIKET,'Y',0,IP2,0,0,DATYP,.FALSE.)
*
IECR = FSTECR (PHYSE(1,HS),STOK,NPAK,serstd,date(14),0,0,NSTAT,
1 1,1,0,IP2,0,TV,'HS',ETIKET,'Y',0,IP2,0,0,DATYP,.FALSE.)
*
IECR = FSTECR (PHYSE(1,AL),STOK,NPAK,serstd,date(14),0,0,NSTAT,
1 1,1,0,IP2,0,TV,'AL',ETIKET,'Y',0,IP2,0,0,DATYP,.FALSE.)
*
IECR = FSTECR (PHYSE(1,TMP),STOK,NPAK,serstd,date(14),0,0,NSTAT,
1 1,1,0,IP2,0,TV,'TP',ETIKET,'Y',0,IP2,0,0,DATYP,.FALSE.)
*
IECR = FSTECR (PHYSE(1,Z0),STOK,NPAK,serstd,date(14),0,0,NSTAT,
1 1,1,0,IP2,0,TV,'Z0',ETIKET,'Y',0,IP2,0,0,DATYP,.FALSE.)
*
IECR = FSTECR (PHYSE(1,CND),STOK,NPAK,serstd,date(14),0,0,NSTAT,
1 1,1,0,IP2,0,TV,'PS',ETIKET,'Y',0,IP2,0,0,DATYP,.FALSE.)
*
IECR = FSTECR (PHYSE(1,SD),STOK,NPAK,serstd,date(14),0,0,NSTAT,
1 1,1,0,IP2,0,TV,'SD',ETIKET,'Y',0,IP2,0,0,DATYP,.FALSE.)
*
IECR = FSTECR (PHYSE(1,GL),STOK,NPAK,serstd,date(14),0,0,NSTAT,
1 1,1,0,IP2,0,TV,'GL',ETIKET,'Y',0,IP2,0,0,DATYP,.FALSE.)
*
*
* ------------------------------------------------------
*
* DESALLOUER LA MEMOIRE
*
DEALLOCATE (HH )
DEALLOCATE (STOK )
DEALLOCATE (DIAG )
DEALLOCATE (PHYSE)
DEALLOCATE (SERS_T )
DEALLOCATE (SERP_T )
*
RETURN
END