| 1 | SUBROUTINE writeg1d(ngrid,nx,x,nom,titre) |
|---|
| 2 | IMPLICIT NONE |
|---|
| 3 | |
|---|
| 4 | c....................................................................... |
|---|
| 5 | c |
|---|
| 6 | c ecriture de x pour GRADS-1D |
|---|
| 7 | c |
|---|
| 8 | c in : |
|---|
| 9 | c * ngrid ---> pour controler que l'on est bien en 1D |
|---|
| 10 | c * nx ---> taille du vecteur a stocker |
|---|
| 11 | c "1" pour une variable de surface |
|---|
| 12 | c "nlayer" pour une variable de centre de couche |
|---|
| 13 | c "nlayer+1" pour une variable d'interface |
|---|
| 14 | c * x ---> variable a stocker |
|---|
| 15 | c * nom ---> nom "pour grads" |
|---|
| 16 | c * titre ---> titre "pour grads" |
|---|
| 17 | c |
|---|
| 18 | c....................................................................... |
|---|
| 19 | c |
|---|
| 20 | #include "comg1d.h" |
|---|
| 21 | |
|---|
| 22 | c |
|---|
| 23 | c....................................................................... |
|---|
| 24 | c declaration des arguments |
|---|
| 25 | c |
|---|
| 26 | INTEGER ngrid,nx,i |
|---|
| 27 | REAL*4 xr4(1000) |
|---|
| 28 | REAL x(nx) |
|---|
| 29 | CHARACTER*(*) nom,titre |
|---|
| 30 | c |
|---|
| 31 | c declaration des arguments |
|---|
| 32 | c....................................................................... |
|---|
| 33 | c declaration des variables locales |
|---|
| 34 | c |
|---|
| 35 | INTEGER ilayer,ivar |
|---|
| 36 | LOGICAL test |
|---|
| 37 | c |
|---|
| 38 | c declaration des variables locales |
|---|
| 39 | c....................................................................... |
|---|
| 40 | c controle 1D |
|---|
| 41 | c |
|---|
| 42 | c print*,'ngrid=',ngrid |
|---|
| 43 | IF (ngrid.NE.1) return |
|---|
| 44 | c |
|---|
| 45 | c controle 1D |
|---|
| 46 | c....................................................................... |
|---|
| 47 | c copy => force en reel 4 pour l'ecriture dans grads1d.dat |
|---|
| 48 | |
|---|
| 49 | do i=1,nx |
|---|
| 50 | xr4(i) = x(i) |
|---|
| 51 | enddo |
|---|
| 52 | |
|---|
| 53 | c copy => force en reel 4 pour l'ecriture dans grads1d.dat |
|---|
| 54 | c....................................................................... |
|---|
| 55 | c ouverture du fichier au premier appel |
|---|
| 56 | |
|---|
| 57 | |
|---|
| 58 | g1d_nomfich='g1d.dat' |
|---|
| 59 | |
|---|
| 60 | IF (g1d_premier) THEN |
|---|
| 61 | OPEN (g1d_unitfich,FILE=g1d_nomfich |
|---|
| 62 | & ,FORM='unformatted',ACCESS='direct',RECL=4) |
|---|
| 63 | g1d_irec=0 |
|---|
| 64 | g1d_nvar=0 |
|---|
| 65 | g1d_premier=.false. |
|---|
| 66 | ENDIF |
|---|
| 67 | |
|---|
| 68 | c ouverture du fichier au premier appel |
|---|
| 69 | c....................................................................... |
|---|
| 70 | c pour l'ecriture du fichier ctl |
|---|
| 71 | |
|---|
| 72 | test=.true. |
|---|
| 73 | DO ivar=1,g1d_nvar |
|---|
| 74 | IF (nom.EQ.g1d_nomvar(ivar)) test=.false. |
|---|
| 75 | IF (nx .GT. 1000) then |
|---|
| 76 | print*,'ERROR: nx > 1000 dans writeg1d.F' |
|---|
| 77 | print*,'Changer la dimension de xr4' |
|---|
| 78 | call exit(1) |
|---|
| 79 | ENDIF |
|---|
| 80 | ENDDO |
|---|
| 81 | IF (test) THEN |
|---|
| 82 | g1d_nvar=g1d_nvar+1 |
|---|
| 83 | g1d_nomvar(g1d_nvar)=nom |
|---|
| 84 | g1d_titrevar(g1d_nvar)=titre |
|---|
| 85 | IF (nx.EQ.1) THEN |
|---|
| 86 | g1d_dimvar(g1d_nvar)=0 |
|---|
| 87 | ELSEIF (nx.EQ.g1d_nlayer) THEN |
|---|
| 88 | g1d_dimvar(g1d_nvar)=g1d_nlayer |
|---|
| 89 | ELSEIF (nx.EQ.g1d_nlayer+1) THEN |
|---|
| 90 | g1d_dimvar(g1d_nvar)=g1d_nlayer+1 |
|---|
| 91 | ELSE |
|---|
| 92 | PRINT *,'._. probleme de dimension dans GRADS-1D ._.' |
|---|
| 93 | print*,'NX = ',nx |
|---|
| 94 | print*,'g1d_nlayer = ',g1d_nlayer |
|---|
| 95 | ENDIF |
|---|
| 96 | ENDIF |
|---|
| 97 | c |
|---|
| 98 | c pour l'ecriture du fichier ctl |
|---|
| 99 | c....................................................................... |
|---|
| 100 | c ecriture |
|---|
| 101 | c |
|---|
| 102 | IF (nx.EQ.1) THEN |
|---|
| 103 | g1d_irec=g1d_irec+1 |
|---|
| 104 | WRITE(g1d_unitfich,REC=g1d_irec) xr4(1) |
|---|
| 105 | ELSE |
|---|
| 106 | DO ilayer=1,g1d_nlayer |
|---|
| 107 | g1d_irec=g1d_irec+1 |
|---|
| 108 | WRITE(g1d_unitfich,REC=g1d_irec) xr4(ilayer) |
|---|
| 109 | ENDDO |
|---|
| 110 | ENDIF |
|---|
| 111 | c |
|---|
| 112 | c ecriture |
|---|
| 113 | c....................................................................... |
|---|
| 114 | c |
|---|
| 115 | 10001 CONTINUE |
|---|
| 116 | c |
|---|
| 117 | c....................................................................... |
|---|
| 118 | c |
|---|
| 119 | RETURN |
|---|
| 120 | END |
|---|
| 121 | |
|---|
| 122 | |
|---|
| 123 | |
|---|
| 124 | |
|---|
| 125 | |
|---|
| 126 | c ********************************************************************* |
|---|
| 127 | c ********************************************************************* |
|---|
| 128 | |
|---|
| 129 | SUBROUTINE endg1d(ngrid,nlayer,zlayer,ndt) |
|---|
| 130 | IMPLICIT NONE |
|---|
| 131 | c....................................................................... |
|---|
| 132 | c |
|---|
| 133 | c ecriture du fichier de controle pour GRADS-1D |
|---|
| 134 | c |
|---|
| 135 | c in : |
|---|
| 136 | c * ngrid ---> pour controler que l'on est bien en 1D |
|---|
| 137 | c * nlayer ---> nombre de couches |
|---|
| 138 | c * zlayer ---> altitude au centre de chaque couche (km) |
|---|
| 139 | c * ndt ---> nombre de pas de temps |
|---|
| 140 | c |
|---|
| 141 | c....................................................................... |
|---|
| 142 | c |
|---|
| 143 | #include "comg1d.h" |
|---|
| 144 | #include "comcstfi.h" |
|---|
| 145 | |
|---|
| 146 | |
|---|
| 147 | c |
|---|
| 148 | c....................................................................... |
|---|
| 149 | c declaration des arguments |
|---|
| 150 | c |
|---|
| 151 | INTEGER ngrid,nlayer |
|---|
| 152 | REAL zlayer(nlayer) |
|---|
| 153 | INTEGER ndt |
|---|
| 154 | c |
|---|
| 155 | c declaration des arguments |
|---|
| 156 | c....................................................................... |
|---|
| 157 | c declaration des variables locales |
|---|
| 158 | c |
|---|
| 159 | INTEGER ivar,ilayer |
|---|
| 160 | c |
|---|
| 161 | |
|---|
| 162 | |
|---|
| 163 | ! integer saveG1D |
|---|
| 164 | |
|---|
| 165 | c declaration des variables locales |
|---|
| 166 | c....................................................................... |
|---|
| 167 | c contole 1D |
|---|
| 168 | c |
|---|
| 169 | IF (ngrid.NE.1) GOTO 10001 |
|---|
| 170 | c |
|---|
| 171 | c contole 1D |
|---|
| 172 | c....................................................................... |
|---|
| 173 | c |
|---|
| 174 | IF (nlayer.ne.g1d_nlayer) |
|---|
| 175 | &PRINT *,'._. probleme de dimension dans GRADS-1D (endg1d.F) ' |
|---|
| 176 | c |
|---|
| 177 | c....................................................................... |
|---|
| 178 | c |
|---|
| 179 | CLOSE (g1d_unitfich) |
|---|
| 180 | c |
|---|
| 181 | c....................................................................... |
|---|
| 182 | |
|---|
| 183 | |
|---|
| 184 | OPEN (g1d_unitctl,FILE=g1d_nomctl,FORM='formatted',RECL=4*100) |
|---|
| 185 | WRITE (g1d_unitctl,'(a4,2x,a1,a20)') 'DSET','^',g1d_nomfich |
|---|
| 186 | WRITE (g1d_unitctl,'(a5,2x,a20)') 'UNDEF ','1.E+30' |
|---|
| 187 | WRITE (g1d_unitctl,'(a11)') 'FORMAT YREV' |
|---|
| 188 | WRITE (g1d_unitctl,'(a5,2x,a30)') 'TITLE ','champs 1D' |
|---|
| 189 | WRITE (g1d_unitctl,'(a5,i4,a20)') 'XDEF ',1,' LINEAR 0 1' |
|---|
| 190 | WRITE (g1d_unitctl,'(a5,i4,a20)') 'YDEF ',1,' LINEAR 0 1' |
|---|
| 191 | WRITE (g1d_unitctl,'(a5,i4,a20)') 'ZDEF ',g1d_nlayer,' LEVELS' |
|---|
| 192 | WRITE (g1d_unitctl,'(5(1x,f13.5))') |
|---|
| 193 | & (zlayer(ilayer),ilayer=1,g1d_nlayer) |
|---|
| 194 | |
|---|
| 195 | c Writing true timestep in g1d.ctl (in planet "minutes"= sol/(60*24) |
|---|
| 196 | ! ivar =min( max(int(1440.*dtphys/daysec +0.5),1) , 99) |
|---|
| 197 | ! WRITE (g1d_unitctl,'(a4,2x,i10,a19,i2,a2)') |
|---|
| 198 | ! & 'TDEF ',ndt,' LINEAR 01JAN2000 ', ivar,'MN ' |
|---|
| 199 | |
|---|
| 200 | ivar =min( max(int(1440.*dtphys*saveG1D/daysec +0.5),1) , 99) |
|---|
| 201 | ! not sure ivar is right, but it doesnt matter |
|---|
| 202 | WRITE (g1d_unitctl,'(a4,2x,i10,a19,i2,a2)') |
|---|
| 203 | & 'TDEF ',ndt/saveG1D,' LINEAR 01JAN2000 ', ivar,'MN ' |
|---|
| 204 | |
|---|
| 205 | WRITE (g1d_unitctl,'(a5,i5)') 'VARS ',g1d_nvar |
|---|
| 206 | DO ivar=1,g1d_nvar |
|---|
| 207 | WRITE (g1d_unitctl,'(a9,3x,i4,i3,1x,a39)') |
|---|
| 208 | & g1d_nomvar(ivar),g1d_dimvar(ivar),99,g1d_titrevar(ivar) |
|---|
| 209 | ENDDO |
|---|
| 210 | WRITE (g1d_unitctl,'(a7)') 'ENDVARS' |
|---|
| 211 | CLOSE (g1d_unitctl) |
|---|
| 212 | c |
|---|
| 213 | c....................................................................... |
|---|
| 214 | c |
|---|
| 215 | 10001 CONTINUE |
|---|
| 216 | c |
|---|
| 217 | c....................................................................... |
|---|
| 218 | c |
|---|
| 219 | RETURN |
|---|
| 220 | END |
|---|
