!-------------------------------------- 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 --------------------------------------
***S/P SERIE - PROCESSEUR DE SERIES TEMPORELLES DES MODELES SEF, MC2 ET GEM
#include "phy_macros_f.h"
SUBROUTINE SERIE(INPUNIT,SERSTD,STATUS,ECHO,COMPRESS,HOUR64, 1,16
$ F_DIAG,F_NIG,F_NK_HYBM,F_NK_HYBT,F_NCOEF)
use Grid_Descriptors, only:grid_descriptor,gd_new,gd_print,gd_write,GD_OK
IMPLICIT NONE
INTEGER INPUNIT,SERSTD,STATUS,F_NIG,F_NK_HYBM,
$ F_NK_HYBT,F_NCOEF
LOGICAL ECHO,COMPRESS,HOUR64,F_DIAG
*
*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
* 022 K. Winger (Apr 2006) - Adapt to time series version 2.00
* (12 characters etiket, real*8 heure,
* account for accumulators, and HY record added)
* 023 K. Winger (Jul 2006) - Account for 4 character variables
* 024 B. Bilodeau (Mar 2007) - Compression
* 025 R. McTaggart-Cowan (Mar 2009) - Use ptop, pref and coef for vertical
* coordinate description
*
*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
* COMPRESS .TRUE. compressed output
* .FALSE. uncompressed output
* HOUR64 .TRUE. to write a 64-bit real (double) for the forecast hour
* .FALSE. to write a 32-bit real (float) for the forecast hour
* F_DIAG .TRUE. to run diagnostics
* .FALSE. to shut off diagnostic calculation
*
*
*Note
* Reference: "PASTEMP" J.Caveen October 1989
*
*parametres
*
#include "maxlev.cdk"
*
*IMPLICITES
#include "sercmdk.cdk"
*
*MODULES
*
INTEGER FSTECR,FSTECR_S
EXTERNAL FSTECR,FSTECR_S
EXTERNAL SERPAT2
EXTERNAL SERFIN
EXTERNAL SERECRI2
INTEGER INDSERI
EXTERNAL INDSERI
EXTERNAL DIFUVD8
INTEGER HYBREF_TO_IG
EXTERNAL HYBREF_TO_IG
*
*NOTE
* REFERENCE: "GRAPHIQUES POUR LES DIAGNOSTIQUES PONCTUELS
* COMMUNICATION NO 6 GROUPE DU MODELE SPECTRAL" OCT 83.
**
*
* AUTOMATIC ARRAYS
integer, dimension(F_nig) :: ig
integer, dimension(F_nk_hybm) :: ip1m
integer, dimension(F_nk_hybt) :: ip1t
real, dimension(F_nk_hybm) :: hybm
real, dimension(F_nk_hybt) :: hybt
real, dimension(F_ncoef) :: rcoef
real(kind=8), dimension(F_nk_hybm) :: am_8,bm_8
real(kind=8), dimension(F_nk_hybt) :: at_8,bt_8
*
* VARIABLES ALLOUEES DYNAMIQUEMENT
*
REAL*8 , DIMENSION(:) , ALLOCATABLE:: HH8
REAL , DIMENSION(:) , ALLOCATABLE:: HH, STOK, DIAG
REAL , DIMENSION(:,:) , ALLOCATABLE:: PHYSE,SER_SFC,SER_PROF
REAL , DIMENSION(:,:,:) , ALLOCATABLE:: SERS_T
REAL , DIMENSION(:,:,:,:) , ALLOCATABLE:: SERP_T
*
INTEGER, PARAMETER :: STDOUT=6
*
INTEGER TMP,AL,MG,Z0,HS,CND,LAT,LON,GL,NE,MAP,SD,NIG
INTEGER NK_HYBM,NK_HYBT,NCOEF,VCODE,ERR
CHARACTER *4 NOMVAR(NVAR), MODELE*3
*
REAL DGRW,RGAS,GRAV
CHARACTER *8 ETIKET8
CHARACTER *12 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,VKIND
LOGICAL SATUES, SATUCO
REAL(KIND=8) :: PTOP_8,PREF_8
*
REAL DEGRAD ,scrap
REAL CONVERTI
REAL IG1,IG2,IG3,IG4,X1,X2
LOGICAL IBM32_2_IEEE
*
TYPE(GRID_DESCRIPTOR) :: gd
*
REWIND INPUNIT
*
NREC = 1
*
* CHAMPS PHYSIQUES INVARIANTS
*
NSKIP = 3
READ (inpunit,end=2) CONVERTI, NSTAT,
X (NAME(L),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,NIG,(IG(K),K=1,NIG),
W DGRW, RGAS, GRAV, SATUES, SATUCO,
X TSMOYHR, SRWRI, NK_HYBM,
Y (HYBM(M),AM_8(M),BM_8(M),M=1,NK_HYBM),NK_HYBT,
A (HYBT(M),AT_8(M),BT_8(M),M=1,NK_HYBT),NCOEF,
B (RCOEF(M),M=1,NCOEF),PTOP_8,PREF_8,VCODE
*
* 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
print*, 'STOP!!! 64 bit conversion unimplemented'
stop
!call ibm64_ieee(PTOP_8,1)
call ibm32_ieee(RCOEF,size(RCOEF))
call ibm32_ieee(DGRW,1)
call ibm32_ieee(RGAS,1)
call ibm32_ieee(GRAV,1)
*
ENDIF
*
NREC = NREC + 1
*
WRITE ( STDOUT , * ) 'NSTAT = ',NSTAT
WRITE ( STDOUT , * ) 'IJSTAT = ',(IJSTAT(L,1),L=1,NSTAT)
WRITE ( STDOUT , * ) 'JSTAT = ',(JSTAT(L),L=1,NSTAT)
WRITE ( STDOUT , * ) 'NK = ',NK,' HYBRID(M) = ',(HYBM(K),K=1,NK_HYBM)
WRITE ( STDOUT , * ) 'PTOP_8 ',PTOP_8,' RCOEF = ',RCOEF
WRITE ( STDOUT , * ) 'DGRW = ',DGRW,' RGAS = ',RGAS,' GRAV = ',GRAV
WRITE ( STDOUT , '(1X,I3,20(1X,A4))' )
Y NPHYE,(NOMVAR(M),M=1,NPHYE)
WRITE ( STDOUT , '(1X,I3,20(1X,A4))' )
Z NPROF,(PROFILS(M,1),M=1,NPROF)
WRITE ( STDOUT , '(1X,9HETIKET = ,A12)' ) ETIKET
WRITE ( STDOUT , 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
print*, 'STOP!!! 64 bit conversion unimplemented'
stop
!call ibm64_ieee(HEURE,1)
call ibm32_ieee(PHYSE,MXSTT*NPHYE)
ENDIF
*
WRITE ( STDOUT , * ) 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 , END=2 ) CONVERTI, NSTAT,
X (NAME(L),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,NIG,(IG(K),K=1,NIG),
W DGRW, RGAS, GRAV, SATUES, SATUCO,
X TSMOYHR, SRWRI, NK_HYBM,
Y (HYBM(M),AM_8(M),BM_8(M),M=1,NK_HYBM),
Z NK_HYBT,
A (HYBT(M),AT_8(M),BT_8(M),M=1,NK_HYBT),
B NCOEF,(RCOEF(M),M=1,NCOEF),
C PTOP_8,VCODE
*
* CONVERSION DES REELS DU FORMAT IBM 32 BITS AU FORMAT IEEE
IF (ibm32_2_ieee) THEN
print*, 'STOP!!! 64 bit conversion unimplemented'
stop
!call ibm64_ieee(PTOP_8,1)
call ibm32_ieee(RCOEF,size(RCOEF))
call ibm32_ieee(DGRW,1)
call ibm32_ieee(RGAS,1)
call ibm32_ieee(GRAV,1)
ENDIF
*
WRITE ( STDOUT , * ) 'NSTAT = ',NSTAT
WRITE ( STDOUT , * ) 'IJSTAT = ',(IJSTAT(L,1),L=1,NSTAT)
WRITE ( STDOUT , * ) 'JSTAT = ',(JSTAT(L),L=1,NSTAT)
WRITE ( STDOUT , * ) 'NK = ',NK,' HYBRID(M) = ',(HYBM(K),K=1,NK_HYBM)
WRITE ( STDOUT , * ) 'PTOP_8 = ',PTOP_8,' RCOEF = ',RCOEF
WRITE ( STDOUT , * ) 'TSMOYHR = ',TSMOYHR,' SRWRI = ',SRWRI
WRITE ( STDOUT , * ) 'DGRW = ',DGRW,' RGAS = ',RGAS,' GRAV = ',GRAV
WRITE ( STDOUT , '(1X,I3,20(1X,A4))' )
Y NSURF,(SURFACE(M,1),M=1,NSURF)
WRITE ( STDOUT , '(1X,I3,20(1X,A4))' )
Z NPROF,(PROFILS(M,1),M=1,NPROF)
WRITE ( STDOUT , '(1X,9HETIKET = ,A12)' ) ETIKET
WRITE ( STDOUT , 6060 ) DATE
*
WRITE ( STDOUT , 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 ( STDOUT , * ) 'MODELE SEF'
*
ELSE IF ( ETIKMAJ(1:1) .EQ. 'F' ) THEN
*
MODELE = 'EFR'
WRITE ( STDOUT , * ) 'MODELE EFR'
*
ELSE IF ( ETIKMAJ(1:1) .EQ. 'G' ) THEN
*
MODELE = 'GEF'
WRITE ( STDOUT , * ) 'MODELE GEF'
*
ELSE
*
* PAR DEFAUT, PAS DE ROTATION POUR LES AUTRES MODELES
*
ENDIF
*
* ALLOUER LA MEMOIRE
*
ALLOCATE ( HH8(NT) )
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) HH8(I)
*
* CONVERSION DES REELS DU FORMAT IBM 32 BITS AU FORMAT IEEE
IF (ibm32_2_ieee) THEN
print*, 'STOP!!! 64 bit conversion unimplemented'
stop
!call ibm64_ieee(HH8(I),1)
ENDIF
*
7 continue
WRITE ( STDOUT , * ) 'HEURES = ',(HH8(I),I=1,NT)
*
*
* AJOUTER L'HEURE INITIALE
*
DO 8 I=1,NT
8 HH8(I) = HH8(I) + dble(DATE(5))
WRITE ( STDOUT , * ) 'HEURES = ',(HH8(I),I=1,NT)
HH = real(HH8)
*
* WRITE LIST OF FORECAST HOURS
*
TV='T'
NPAK=-32
DATYP=5
IP2 =FLOAT(DATE(5))*100
IF ( HOUR64 ) then
IECR = FSTECR(HH8,STOK,-64,SERSTD,DATE(14),0,0,NT,1,1,
1 0,0,0,TV,'HH',ETIKET,'T',0,0,0,0,DATYP,.TRUE.)
ELSE
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.)
ENDIF
*
* WRITE LIST OF STATION NAMES (64-bit limit in FSTD)
*
IECR = FSTECR_S(NAME,STOK,-8,SERSTD,DATE(14),0,0,
1 STN_STRING_LENGTH,NSTAT,1,0,0,0,TV,
2 'STNS',ETIKET,'T',0,0,0,0,7,.TRUE.)
*
* GENERATE HYBRID COORDINATE DESCRIPTION
*
vkind = 5 !hybrid coordinate
do i=2,size(hybm)
call convip(ip1m(i),hybm(i),vkind,+2,'',.false.)
enddo
do i=1,size(hybt)
call convip(ip1t(i),hybt(i),vkind,+2,'',.false.)
enddo
status = gd_new(self=gd, !descriptor instance
$ kind=vkind, !coordinate type
$ version=2, !staggered (see dynamics level.cdk)
$ nk=F_NK_HYBM-2, !number of vertical levels
$ ptop_8=PTOP_8, !pressure of model top
$ pref_8=PREF_8, !reference pressure
$ rcoef1=RCOEF(1), !first R-coefficient
$ rcoef2=RCOEF(2), !second R-coefficient
$ a_m_8=AM_8(2:), !momentum level A-values
$ b_m_8=BM_8(2:), !momentum level B-values
$ a_t_8=AT_8, !thermodynamic level A-values
$ b_t_8=BT_8, !thermodynamic level B-values
$ ip1_m=ip1m(2:), !list of IP1s for momentum levels
$ ip1_t=ip1t) !list of IP1s for thermodynamic levels
if (status /= GD_OK) then
write(STDOUT,*) 'WARNING: grid descriptor constructor returned error ',status
else
status = gd_print(gd,stdout=STDOUT)
status = gd_write(gd,unit=serstd,format='fst')
if (status /= GD_OK) then
write(STDOUT,*) 'WARNING: error writing grid descriptor: ',status
endif
endif
*
* OUTPUT A LIST OF HYBRID COORDINATES FOR PLOTTING
*
IECR = FSTECR(HYBT,STOK,NPAK,SERSTD,DATE(14),0,0,size(HYBT),1,1,
1 0,0,0,TV,'SH',ETIKET,'T',0,0,0,0,DATYP,.TRUE.)
IECR = FSTECR(HYBM,STOK,NPAK,SERSTD,DATE(14),0,0,size(HYBM),1,1,
1 0,0,0,TV,'SV',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
print*, 'STOP - 64-bit conversion unimplenented'
stop
!call ibm64_ieee(HEURE,1)
call ibm32_ieee(SERS,MXSTT*NSURF)
call ibm32_ieee(SERP,MXNVO*MXSTT*NPROF)
ENDIF
*
IF (ECHO) THEN
WRITE (STDOUT,*) ' HEURE=',HEURE
DO L=1,NSTAT
WRITE (STDOUT,*) ' STATION NO.',L
WRITE (STDOUT,*) ' SURFACES=',(SERS(L,M),M=1,NSURF)
DO 20 M=1,NPROF
20 WRITE (STDOUT,*) ' 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)
*
* ACCOUNT FOR ACCUMULATORS IN CASE THEY WERE
* NOT RESET TO ZERO EVERY TIME SERIES OUTPUT TIME STEP
*
IF (TSMOYHR > 0 .and. SRWRI > 0)
1 CALL SERACC(SERS_T(1,1,L),HH8,NSURF,NT,SURFACE,TSMOYHR,SRWRI)
*
* ECRIRE SERIES POUR CE POINT SUR SERSTD
*
CALL SERECRI2(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,size(AT_8),AT_8,BT_8,real(PTOP_8),DIAG,DATE(14),
3 ETIKET,FLOAT(DATE(5)), NK, SATUES, SATUCO, COMPRESS, F_DIAG)
*
*
*
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 (HH8 )
DEALLOCATE (HH )
DEALLOCATE (STOK )
DEALLOCATE (DIAG )
DEALLOCATE (PHYSE)
DEALLOCATE (SERS_T )
DEALLOCATE (SERP_T )
*
RETURN
END