| 1 | SUBROUTINE inidissip ( lstardis,nitergdiv,nitergrot,niterh , |
|---|
| 2 | * tetagdiv,tetagrot,tetatemp ) |
|---|
| 3 | c======================================================================= |
|---|
| 4 | c initialisation de la dissipation horizontale |
|---|
| 5 | c======================================================================= |
|---|
| 6 | c----------------------------------------------------------------------- |
|---|
| 7 | c declarations: |
|---|
| 8 | c ------------- |
|---|
| 9 | |
|---|
| 10 | IMPLICIT NONE |
|---|
| 11 | #include "dimensions.h" |
|---|
| 12 | #include "paramet.h" |
|---|
| 13 | #include "comdissipn.h" |
|---|
| 14 | #include "comconst.h" |
|---|
| 15 | #include "comvert.h" |
|---|
| 16 | #include "control.h" |
|---|
| 17 | |
|---|
| 18 | LOGICAL lstardis |
|---|
| 19 | INTEGER nitergdiv,nitergrot,niterh |
|---|
| 20 | REAL tetagdiv,tetagrot,tetatemp |
|---|
| 21 | REAL zvert(llm),zz |
|---|
| 22 | REAL zh(ip1jmp1),zu(ip1jmp1),zv(ip1jm),deltap(ip1jmp1,llm) |
|---|
| 23 | REAL ullm,vllm,umin,vmin,zhmin,zhmax |
|---|
| 24 | REAL zllm,z1llm |
|---|
| 25 | |
|---|
| 26 | INTEGER l,ij,idum,ii |
|---|
| 27 | REAL tetamin |
|---|
| 28 | |
|---|
| 29 | EXTERNAL ran1 |
|---|
| 30 | REAL ran1 |
|---|
| 31 | real sig_s(llm) |
|---|
| 32 | save sig_s |
|---|
| 33 | logical firstcall |
|---|
| 34 | data firstcall/.true./ |
|---|
| 35 | save firstcall |
|---|
| 36 | |
|---|
| 37 | REAL fac_mid |
|---|
| 38 | REAL fac_up |
|---|
| 39 | REAL delta |
|---|
| 40 | REAL middle,startalt |
|---|
| 41 | SAVE fac_mid, fac_up, delta, startalt, middle |
|---|
| 42 | |
|---|
| 43 | c ------------------------------------------------------ |
|---|
| 44 | if (firstcall) then |
|---|
| 45 | firstcall=.false. |
|---|
| 46 | |
|---|
| 47 | do l=1,llm |
|---|
| 48 | sig_s(l)=aps(l)/preff + bps(l) |
|---|
| 49 | enddo |
|---|
| 50 | |
|---|
| 51 | c COMPUTING THE VARIATION OF DISSIPATION AS A FUNCTION OF MODEL TOP : |
|---|
| 52 | c FF 2004 !! TB15 lt.160 |
|---|
| 53 | if (pseudoalt(llm).lt.200.) then |
|---|
| 54 | fac_mid=2 !2 coeff pour dissipation aux basses/moyennes altitudes |
|---|
| 55 | fac_up=10 !10 coeff multiplicateur pour dissipation hautes altitudes |
|---|
| 56 | startalt=90. !90 altitude en Km de la transition mid / up |
|---|
| 57 | delta=20.!20 Intervalle (km) pour le changement mid / up |
|---|
| 58 | else ! thermosphere model |
|---|
| 59 | fac_mid=2 ! coeff pour dissipation aux basses/moyennes altitudes |
|---|
| 60 | fac_up=25 ! coeff multiplicateur pour dissipation hautes altitudes |
|---|
| 61 | c startalt: 95 OK for MY24 |
|---|
| 62 | startalt=95. ! altitude en Km de la transition mid / up |
|---|
| 63 | delta=30.! Intervalle (km) pour le changement mid /up |
|---|
| 64 | end if |
|---|
| 65 | middle=startalt+delta/2 |
|---|
| 66 | write(*,*) 'Dissipation : ' |
|---|
| 67 | write(*,*) 'Multiplication de la dissipation en altitude :', |
|---|
| 68 | & ' fac_mid, fac_up =', fac_mid, fac_up, |
|---|
| 69 | & ' pseudoalt(llm) =', pseudoalt(llm) |
|---|
| 70 | write(*,*) 'Transition mid /up : startalt, delta =', |
|---|
| 71 | & startalt, delta , '(km)' |
|---|
| 72 | endif |
|---|
| 73 | |
|---|
| 74 | c----------------------------------------------------------------------- |
|---|
| 75 | c |
|---|
| 76 | c calcul des valeurs propres des operateurs par methode iterrative: |
|---|
| 77 | c ----------------------------------------------------------------- |
|---|
| 78 | |
|---|
| 79 | crot = -1. |
|---|
| 80 | cdivu = -1. |
|---|
| 81 | cdivh = -1. |
|---|
| 82 | |
|---|
| 83 | c calcul de la valeur propre de divgrad: |
|---|
| 84 | c -------------------------------------- |
|---|
| 85 | idum = 0 |
|---|
| 86 | DO l = 1, llm |
|---|
| 87 | DO ij = 1, ip1jmp1 |
|---|
| 88 | deltap(ij,l) = 1. |
|---|
| 89 | ENDDO |
|---|
| 90 | ENDDO |
|---|
| 91 | |
|---|
| 92 | idum = -1 |
|---|
| 93 | zh(1) = RAN1(idum)-.5 |
|---|
| 94 | idum = 0 |
|---|
| 95 | DO ij = 2, ip1jmp1 |
|---|
| 96 | zh(ij) = RAN1(idum) -.5 |
|---|
| 97 | ENDDO |
|---|
| 98 | ! test |
|---|
| 99 | print*,'ok' |
|---|
| 100 | CALL filtreg (zh,jjp1,1,2,1,.TRUE.,1) |
|---|
| 101 | print*,'ok2' |
|---|
| 102 | CALL minmax(iip1*jjp1,zh,zhmin,zhmax ) |
|---|
| 103 | |
|---|
| 104 | IF ( zhmin .GE. zhmax ) THEN |
|---|
| 105 | PRINT*,' Inidissip zh min max ',zhmin,zhmax |
|---|
| 106 | STOP'probleme generateur alleatoire dans inidissip' |
|---|
| 107 | ENDIF |
|---|
| 108 | |
|---|
| 109 | zllm = ABS( zhmax ) |
|---|
| 110 | DO l = 1,50 |
|---|
| 111 | IF(lstardis) THEN |
|---|
| 112 | CALL divgrad2(1,zh,deltap,niterh,zh) |
|---|
| 113 | ELSE |
|---|
| 114 | CALL divgrad (1,zh,niterh,zh) |
|---|
| 115 | ENDIF |
|---|
| 116 | |
|---|
| 117 | CALL minmax(iip1*jjp1,zh,zhmin,zhmax ) |
|---|
| 118 | |
|---|
| 119 | zllm = ABS( zhmax ) |
|---|
| 120 | z1llm = 1./zllm |
|---|
| 121 | DO ij = 1,ip1jmp1 |
|---|
| 122 | zh(ij) = zh(ij)* z1llm |
|---|
| 123 | ENDDO |
|---|
| 124 | ENDDO |
|---|
| 125 | |
|---|
| 126 | IF(lstardis) THEN |
|---|
| 127 | cdivh = 1./ zllm |
|---|
| 128 | ELSE |
|---|
| 129 | cdivh = zllm ** ( -1./niterh ) |
|---|
| 130 | ENDIF |
|---|
| 131 | |
|---|
| 132 | c calcul des valeurs propres de gradiv (ii =1) et nxgrarot(ii=2) |
|---|
| 133 | c ----------------------------------------------------------------- |
|---|
| 134 | print*,'calcul des valeurs propres' |
|---|
| 135 | |
|---|
| 136 | DO 20 ii = 1, 2 |
|---|
| 137 | c |
|---|
| 138 | DO ij = 1, ip1jmp1 |
|---|
| 139 | zu(ij) = RAN1(idum) -.5 |
|---|
| 140 | ENDDO |
|---|
| 141 | CALL filtreg (zu,jjp1,1,2,1,.TRUE.,1) |
|---|
| 142 | DO ij = 1, ip1jm |
|---|
| 143 | zv(ij) = RAN1(idum) -.5 |
|---|
| 144 | ENDDO |
|---|
| 145 | CALL filtreg (zv,jjm,1,2,1,.FALSE.,1) |
|---|
| 146 | |
|---|
| 147 | CALL minmax(iip1*jjp1,zu,umin,ullm ) |
|---|
| 148 | CALL minmax(iip1*jjm, zv,vmin,vllm ) |
|---|
| 149 | |
|---|
| 150 | ullm = ABS ( ullm ) |
|---|
| 151 | vllm = ABS ( vllm ) |
|---|
| 152 | |
|---|
| 153 | DO 5 l = 1, 50 |
|---|
| 154 | IF(ii.EQ.1) THEN |
|---|
| 155 | IF(lstardis) THEN |
|---|
| 156 | CALL gradiv2( 1,zu,zv,nitergdiv,zu,zv ) |
|---|
| 157 | ELSE |
|---|
| 158 | CALL gradiv ( 1,zu,zv,nitergdiv,zu,zv ) |
|---|
| 159 | ENDIF |
|---|
| 160 | ELSE |
|---|
| 161 | IF(lstardis) THEN |
|---|
| 162 | CALL nxgraro2( 1,zu,zv,nitergrot,zu,zv ) |
|---|
| 163 | ELSE |
|---|
| 164 | CALL nxgrarot( 1,zu,zv,nitergrot,zu,zv ) |
|---|
| 165 | ENDIF |
|---|
| 166 | ENDIF |
|---|
| 167 | |
|---|
| 168 | CALL minmax(iip1*jjp1,zu,umin,ullm ) |
|---|
| 169 | CALL minmax(iip1*jjm, zv,vmin,vllm ) |
|---|
| 170 | |
|---|
| 171 | ullm = ABS ( ullm ) |
|---|
| 172 | vllm = ABS ( vllm ) |
|---|
| 173 | |
|---|
| 174 | zllm = MAX( ullm,vllm ) |
|---|
| 175 | z1llm = 1./ zllm |
|---|
| 176 | DO ij = 1, ip1jmp1 |
|---|
| 177 | zu(ij) = zu(ij)* z1llm |
|---|
| 178 | ENDDO |
|---|
| 179 | DO ij = 1, ip1jm |
|---|
| 180 | zv(ij) = zv(ij)* z1llm |
|---|
| 181 | ENDDO |
|---|
| 182 | 5 CONTINUE |
|---|
| 183 | |
|---|
| 184 | IF ( ii.EQ.1 ) THEN |
|---|
| 185 | IF(lstardis) THEN |
|---|
| 186 | cdivu = 1./zllm |
|---|
| 187 | ELSE |
|---|
| 188 | cdivu = zllm **( -1./nitergdiv ) |
|---|
| 189 | ENDIF |
|---|
| 190 | ELSE |
|---|
| 191 | IF(lstardis) THEN |
|---|
| 192 | crot = 1./ zllm |
|---|
| 193 | ELSE |
|---|
| 194 | crot = zllm **( -1./nitergrot ) |
|---|
| 195 | ENDIF |
|---|
| 196 | ENDIF |
|---|
| 197 | |
|---|
| 198 | 20 CONTINUE |
|---|
| 199 | |
|---|
| 200 | c petit test pour les operateurs non star: |
|---|
| 201 | c ---------------------------------------- |
|---|
| 202 | |
|---|
| 203 | c IF(.NOT.lstardis) THEN |
|---|
| 204 | c fac_mid = rad*24./float(jjm) |
|---|
| 205 | c fac_mid = fac_mid*fac_mid |
|---|
| 206 | c PRINT*,'coef u ', fac_mid/cdivu, 1./cdivu |
|---|
| 207 | c PRINT*,'coef r ', fac_mid/crot , 1./crot |
|---|
| 208 | c PRINT*,'coef h ', fac_mid/cdivh, 1./cdivh |
|---|
| 209 | c ENDIF |
|---|
| 210 | |
|---|
| 211 | c----------------------------------------------------------------------- |
|---|
| 212 | c variation verticale du coefficient de dissipation: |
|---|
| 213 | c -------------------------------------------------- |
|---|
| 214 | |
|---|
| 215 | DO l=1,llm |
|---|
| 216 | zvert(l)=1. |
|---|
| 217 | ENDDO |
|---|
| 218 | |
|---|
| 219 | c |
|---|
| 220 | DO l = 1, llm |
|---|
| 221 | zz = 1. -1./sig_s(l) |
|---|
| 222 | zvert(l)= fac_mid -( fac_mid-1.)/( 1.+zz*zz ) |
|---|
| 223 | |
|---|
| 224 | c --------------------------------------------------------------- |
|---|
| 225 | c Utilisation de la fonction tangente hyperbolique pour augmenter |
|---|
| 226 | c arbitrairement la dissipation et donc la stabilite du modele a |
|---|
| 227 | c partir d'une certaine altitude. |
|---|
| 228 | |
|---|
| 229 | c Le facteur multiplicatif de basse atmosphere etant deja pris |
|---|
| 230 | c en compte, il faut diviser le facteur multiplicatif de haute |
|---|
| 231 | c atmosphere par celui-ci. |
|---|
| 232 | c ============================================================ |
|---|
| 233 | |
|---|
| 234 | zvert(l)= zvert(l)*(1.0+((fac_up/fac_mid-1) |
|---|
| 235 | & *(1-(0.5*(1+tanh(-6./delta* |
|---|
| 236 | & (15*(-log(sig_s(l)))-middle))))) |
|---|
| 237 | & )) |
|---|
| 238 | ENDDO |
|---|
| 239 | |
|---|
| 240 | c ----------------------------------------------------------------------------- |
|---|
| 241 | |
|---|
| 242 | c |
|---|
| 243 | |
|---|
| 244 | PRINT*,'Constantes de temps de la diffusion horizontale' |
|---|
| 245 | |
|---|
| 246 | tetamin = 1.e+6 |
|---|
| 247 | |
|---|
| 248 | |
|---|
| 249 | DO l=1,llm |
|---|
| 250 | tetaudiv(l) = zvert(l)/tetagdiv |
|---|
| 251 | tetaurot(l) = zvert(l)/tetagrot |
|---|
| 252 | tetah(l) = zvert(l)/tetatemp |
|---|
| 253 | |
|---|
| 254 | IF( tetamin.GT. (1./tetaudiv(l)) ) tetamin = 1./ tetaudiv(l) |
|---|
| 255 | IF( tetamin.GT. (1./tetaurot(l)) ) tetamin = 1./ tetaurot(l) |
|---|
| 256 | IF( tetamin.GT. (1./ tetah(l)) ) tetamin = 1./ tetah(l) |
|---|
| 257 | ENDDO |
|---|
| 258 | |
|---|
| 259 | c Calcul automatique de idissip |
|---|
| 260 | c ----------------------------- |
|---|
| 261 | c ::::::::::::::::::::: |
|---|
| 262 | c A Commenter pour garder la valeur de run.def : |
|---|
| 263 | c idissip = INT( tetamin/( 2.*dtvr*iperiod) ) * iperiod |
|---|
| 264 | c idissip = MAX(iperiod,idissip) |
|---|
| 265 | c ::::::::::::::::::::: |
|---|
| 266 | dtdiss = idissip * dtvr |
|---|
| 267 | |
|---|
| 268 | PRINT *,' INIDI tetamin dtvr ',tetamin,dtvr,iperiod |
|---|
| 269 | PRINT *,' INIDI tetamin idissip ',tetamin,idissip |
|---|
| 270 | PRINT *,' INIDI idissip dtdiss ',idissip,dtdiss |
|---|
| 271 | c PRINT *,' TB15 :INIDI tetaudiv, rot, ah ',tetaudiv,tetaurot,tetah |
|---|
| 272 | |
|---|
| 273 | PRINT*,'pseudoZ(km) zvert dt(tetagdiv) dt(tetagrot) dt(divgrad)' |
|---|
| 274 | DO l = 1,llm |
|---|
| 275 | PRINT*,pseudoalt(l),zvert(l),dtdiss*tetaudiv(l), |
|---|
| 276 | * dtdiss*tetaurot(l),dtdiss*tetah(l) |
|---|
| 277 | if ( (dtdiss*tetaudiv(l).gt.1.9).or. |
|---|
| 278 | & (dtdiss*tetaurot(l).gt.1.9).or. |
|---|
| 279 | & (dtdiss*tetah(l).gt.1.9)) then |
|---|
| 280 | PRINT *,'STOP : your dissipation is too intense for the ' |
|---|
| 281 | PRINT *,'dissipation timestep : unstable model !' |
|---|
| 282 | PRINT *,'in run.def, you must increase tetagdiv,' |
|---|
| 283 | PRINT *,'(or tetagrot and tetatemp if they are smaller than' |
|---|
| 284 | PRINT *,'tetagdiv) OR decrease idissip OR increase day_step)' |
|---|
| 285 | stop |
|---|
| 286 | end if |
|---|
| 287 | |
|---|
| 288 | ENDDO |
|---|
| 289 | c |
|---|
| 290 | RETURN |
|---|
| 291 | END |
|---|
