SUBROUTINE writeg1d(ngrid,nx,x,nom,titre) IMPLICIT NONE c....................................................................... c c ecriture de x pour GRADS-1D c c in : c * ngrid ---> pour controler que l'on est bien en 1D c * nx ---> taille du vecteur a stocker c "1" pour une variable de surface c "nlayer" pour une variable de centre de couche c "nlayer+1" pour une variable d'interface c * x ---> variable a stocker c * nom ---> nom "pour grads" c * titre ---> titre "pour grads" c c....................................................................... c #include "comg1d.h" c c....................................................................... c declaration des arguments c INTEGER ngrid,nx,i REAL*4 xr4(1000) c REAL xr4(1000) REAL x(nx) CHARACTER*(*) nom,titre c c declaration des arguments c....................................................................... c declaration des variables locales c INTEGER ilayer,ivar LOGICAL test integer isortie ! les sorties ne se font qu'une fois tous les logical oksortie ! nbphypers appels de la physique save isortie c c declaration des variables locales c....................................................................... c controle 1D c c print*,'ngrid=',ngrid IF (ngrid.NE.1) return c c controle 1D c....................................................................... c copy => force en reel 4 pour l'ecriture dans grads1d.dat do i=1,nx xr4(i) = x(i) enddo c copy => force en reel 4 pour l'ecriture dans grads1d.dat c....................................................................... c ouverture du fichier au premier appel c IF (g1d_premier) THEN OPEN (g1d_unitfich,FILE=g1d_nomfich & ,FORM='unformatted',ACCESS='direct',RECL=4) g1d_irec=0 g1d_nvar=0 oksortie= .true. isortie = nbphypers ENDIF c c ouverture du fichier au premier appel c....................................................................... c rythme des sorties if (.not.g1d_premier) then oksortie=.false. if (nom.eq.g1d_nomvar(1)) then if (isortie.eq.nbphypers) then isortie = 1 else if (isortie.eq.(nbphypers-1)) then oksortie=.true. isortie = nbphypers else isortie = isortie+1 endif endif else if (isortie.eq.nbphypers) then oksortie=.true. endif endif endif c rythme des sorties c....................................................................... c pour l'ecriture du fichier ctl c test=.true. DO ivar=1,g1d_nvar IF (nom.EQ.g1d_nomvar(ivar)) test=.false. IF (nx .GT. 1000) then print*,'ERROR: nx > 1000 dans writeg1d.F' print*,'Changer la dimension de xr4' call exit(1) ENDIF ENDDO IF (test) THEN g1d_nvar=g1d_nvar+1 g1d_nomvar(g1d_nvar)=nom g1d_titrevar(g1d_nvar)=titre IF (nx.EQ.1) THEN g1d_dimvar(g1d_nvar)=0 ELSEIF (nx.EQ.g1d_nlayer) THEN g1d_dimvar(g1d_nvar)=g1d_nlayer ELSEIF (nx.EQ.g1d_nlayer+1) THEN g1d_dimvar(g1d_nvar)=g1d_nlayer+1 ELSE PRINT *,'._. probleme de dimension dans GRADS-1D ._.' print*,'NX = ',nx print*,'g1d_nlayer = ',g1d_nlayer ENDIF ENDIF c c pour l'ecriture du fichier ctl c....................................................................... c test pour rythme des sorties if (oksortie) then c print*,nom,isortie,' ok' c....................................................................... c ecriture c IF (nx.EQ.1) THEN g1d_irec=g1d_irec+1 WRITE(g1d_unitfich,REC=g1d_irec) xr4(1) ELSE DO ilayer=1,g1d_nlayer g1d_irec=g1d_irec+1 WRITE(g1d_unitfich,REC=g1d_irec) xr4(ilayer) ENDDO ENDIF c c ecriture c....................................................................... c else c print*,nom,isortie endif c test pour rythme des sorties c....................................................................... c g1d_premier=.false. RETURN END c ********************************************************************* c ********************************************************************* SUBROUTINE endg1d(ngrid,nlayer,zlayer,ndt) IMPLICIT NONE c....................................................................... c c ecriture du fichier de controle pour GRADS-1D c c in : c * ngrid ---> pour controler que l'on est bien en 1D c * nlayer ---> nombre de couches c * zlayer ---> altitude au centre de chaque couche (km) c * ndt ---> nombre de pas de temps c c....................................................................... c #include "comg1d.h" #include "comcstfi.h" c c....................................................................... c declaration des arguments c INTEGER ngrid,nlayer REAL zlayer(nlayer) INTEGER ndt c c declaration des arguments c....................................................................... c declaration des variables locales c INTEGER ivar,ilayer c c declaration des variables locales c....................................................................... c contole 1D c IF (ngrid.NE.1) GOTO 10001 c c contole 1D c....................................................................... c IF (nlayer.ne.g1d_nlayer) &PRINT *,'._. probleme de dimension dans GRADS-1D (endg1d.F) ' c c....................................................................... c CLOSE (g1d_unitfich) c c....................................................................... c OPEN (g1d_unitctl,FILE=g1d_nomctl,FORM='formatted',RECL=4*100) WRITE (g1d_unitctl,'(a4,2x,a1,a20)') 'DSET','^',g1d_nomfich WRITE (g1d_unitctl,'(a5,2x,a20)') 'UNDEF ','1.E+30' WRITE (g1d_unitctl,'(a11)') 'FORMAT YREV' WRITE (g1d_unitctl,'(a5,2x,a30)') 'TITLE ','champs 1D' WRITE (g1d_unitctl,'(a5,i4,a20)') 'XDEF ',1,' LINEAR 0 1' WRITE (g1d_unitctl,'(a5,i4,a20)') 'YDEF ',1,' LINEAR 0 1' WRITE (g1d_unitctl,'(a5,i4,a20)') 'ZDEF ',g1d_nlayer,' LEVELS' WRITE (g1d_unitctl,'(5(1x,f13.5))') & (zlayer(ilayer),ilayer=1,g1d_nlayer) c Writing true timestep in g1d.ctl (in planet "minutes"= sol/(60*24) ivar =min( max(int(1440.*dtphys*nbphypers/daysec +0.5),1) , 99) WRITE (g1d_unitctl,'(a4,2x,i10,a19,i2,a2)') & 'TDEF ',ndt/nbphypers,' LINEAR 01JAN2000 ', ivar,'MN ' WRITE (g1d_unitctl,'(a5,i5)') 'VARS ',g1d_nvar DO ivar=1,g1d_nvar WRITE (g1d_unitctl,'(a9,3x,i4,i3,1x,a39)') & g1d_nomvar(ivar),g1d_dimvar(ivar),99,g1d_titrevar(ivar) ENDDO WRITE (g1d_unitctl,'(a7)') 'ENDVARS' CLOSE (g1d_unitctl) c c....................................................................... c 10001 CONTINUE c c....................................................................... c RETURN END