Changeset 5248 for LMDZ6/trunk/libf
- Timestamp:
- Oct 21, 2024, 7:05:31 PM (15 hours ago)
- Location:
- LMDZ6/trunk/libf
- Files:
-
- 8 moved
-
dyn3d/vlsplt.F90 (moved) (moved from LMDZ6/trunk/libf/dyn3d/vlsplt.F) (1 diff)
-
dyn3dmem/vlsplt_loc.F90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/vlsplt_loc.F) (1 diff)
-
phylmd/cosp/MISR_simulator.f90 (moved) (moved from LMDZ6/trunk/libf/phylmd/cosp/MISR_simulator.F) (1 diff)
-
phylmd/cosp/icarus.f90 (moved) (moved from LMDZ6/trunk/libf/phylmd/cosp/icarus.F) (1 diff)
-
phylmd/cosp/isccp_cloud_types.f90 (moved) (moved from LMDZ6/trunk/libf/phylmd/cosp/isccp_cloud_types.F) (1 diff)
-
phylmd/cosp/pf_to_mr.f90 (moved) (moved from LMDZ6/trunk/libf/phylmd/cosp/pf_to_mr.F) (1 diff)
-
phylmd/cosp/prec_scops.f90 (moved) (moved from LMDZ6/trunk/libf/phylmd/cosp/prec_scops.F) (1 diff)
-
phylmd/cosp/scops.f90 (moved) (moved from LMDZ6/trunk/libf/phylmd/cosp/scops.F) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
LMDZ6/trunk/libf/dyn3d/vlsplt.F90
r5247 r5248 1 c 2 c $Id$ 3 c 4 5 SUBROUTINE vlsplt(q,pente_max,masse,w,pbaru,pbarv,pdt,iq) 6 USE infotrac, ONLY: nqtot,tracers 7 c 8 c Auteurs: P.Le Van, F.Hourdin, F.Forget 9 c 10 c ******************************************************************** 11 c Shema d'advection " pseudo amont " . 12 c ******************************************************************** 13 c q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... 14 c 15 c pente_max facteur de limitation des pentes: 2 en general 16 c 0 pour un schema amont 17 c pbaru,pbarv,w flux de masse en u ,v ,w 18 c pdt pas de temps 19 c 20 c -------------------------------------------------------------------- 21 IMPLICIT NONE 22 c 23 include "dimensions.h" 24 include "paramet.h" 25 26 c 27 c Arguments: 28 c ---------- 29 REAL masse(ip1jmp1,llm),pente_max 30 c REAL masse(iip1,jjp1,llm),pente_max 31 REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm) 32 REAL q(ip1jmp1,llm,nqtot) 33 c REAL q(iip1,jjp1,llm) 34 REAL w(ip1jmp1,llm),pdt 35 INTEGER iq ! CRisi 36 c 37 c Local 38 c --------- 39 c 40 INTEGER ij,l 41 c 42 REAL zm(ip1jmp1,llm,nqtot) 43 REAL mu(ip1jmp1,llm) 44 REAL mv(ip1jm,llm) 45 REAL mw(ip1jmp1,llm+1) 46 REAL zq(ip1jmp1,llm,nqtot) 47 REAL zzpbar, zzw 48 INTEGER ifils,iq2 ! CRisi 49 50 REAL qmin,qmax 51 DATA qmin,qmax/0.,1.e33/ 52 53 zzpbar = 0.5 * pdt 54 zzw = pdt 55 DO l=1,llm 56 DO ij = iip2,ip1jm 57 mu(ij,l)=pbaru(ij,l) * zzpbar 58 ENDDO 59 DO ij=1,ip1jm 60 mv(ij,l)=pbarv(ij,l) * zzpbar 61 ENDDO 62 DO ij=1,ip1jmp1 63 mw(ij,l)=w(ij,l) * zzw 64 ENDDO 1 ! 2 ! $Id$ 3 ! 4 5 SUBROUTINE vlsplt(q,pente_max,masse,w,pbaru,pbarv,pdt,iq) 6 USE infotrac, ONLY: nqtot,tracers 7 ! 8 ! Auteurs: P.Le Van, F.Hourdin, F.Forget 9 ! 10 ! ******************************************************************** 11 ! Shema d'advection " pseudo amont " . 12 ! ******************************************************************** 13 ! q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... 14 ! 15 ! pente_max facteur de limitation des pentes: 2 en general 16 ! 0 pour un schema amont 17 ! pbaru,pbarv,w flux de masse en u ,v ,w 18 ! pdt pas de temps 19 ! 20 ! -------------------------------------------------------------------- 21 IMPLICIT NONE 22 ! 23 include "dimensions.h" 24 include "paramet.h" 25 26 ! 27 ! Arguments: 28 ! ---------- 29 REAL :: masse(ip1jmp1,llm),pente_max 30 ! REAL masse(iip1,jjp1,llm),pente_max 31 REAL :: pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm) 32 REAL :: q(ip1jmp1,llm,nqtot) 33 ! REAL q(iip1,jjp1,llm) 34 REAL :: w(ip1jmp1,llm),pdt 35 INTEGER :: iq ! CRisi 36 ! 37 ! Local 38 ! --------- 39 ! 40 INTEGER :: ij,l 41 ! 42 REAL :: zm(ip1jmp1,llm,nqtot) 43 REAL :: mu(ip1jmp1,llm) 44 REAL :: mv(ip1jm,llm) 45 REAL :: mw(ip1jmp1,llm+1) 46 REAL :: zq(ip1jmp1,llm,nqtot) 47 REAL :: zzpbar, zzw 48 INTEGER :: ifils,iq2 ! CRisi 49 50 REAL :: qmin,qmax 51 DATA qmin,qmax/0.,1.e33/ 52 53 zzpbar = 0.5 * pdt 54 zzw = pdt 55 DO l=1,llm 56 DO ij = iip2,ip1jm 57 mu(ij,l)=pbaru(ij,l) * zzpbar 58 ENDDO 59 DO ij=1,ip1jm 60 mv(ij,l)=pbarv(ij,l) * zzpbar 61 ENDDO 62 DO ij=1,ip1jmp1 63 mw(ij,l)=w(ij,l) * zzw 64 ENDDO 65 ENDDO 66 67 DO ij=1,ip1jmp1 68 mw(ij,llm+1)=0. 69 ENDDO 70 71 CALL SCOPY(ijp1llm,q(1,1,iq),1,zq(1,1,iq),1) 72 CALL SCOPY(ijp1llm,masse,1,zm(1,1,iq),1) 73 74 do ifils=1,tracers(iq)%nqDescen 75 iq2=tracers(iq)%iqDescen(ifils) 76 CALL SCOPY(ijp1llm,q(1,1,iq2),1,zq(1,1,iq2),1) 77 enddo 78 79 !print*,'Entree vlx1' 80 ! call minmaxq(zq,qmin,qmax,'avant vlx ') 81 call vlx(zq,pente_max,zm,mu,iq) 82 !print*,'Sortie vlx1' 83 ! call minmaxq(zq,qmin,qmax,'apres vlx1 ') 84 85 ! print*,'Entree vly1' 86 87 call vly(zq,pente_max,zm,mv,iq) 88 ! call minmaxq(zq,qmin,qmax,'apres vly1 ') 89 !print*,'Sortie vly1' 90 call vlz(zq,pente_max,zm,mw,iq) 91 ! call minmaxq(zq,qmin,qmax,'apres vlz ') 92 93 94 call vly(zq,pente_max,zm,mv,iq) 95 ! call minmaxq(zq,qmin,qmax,'apres vly ') 96 97 98 call vlx(zq,pente_max,zm,mu,iq) 99 ! call minmaxq(zq,qmin,qmax,'apres vlx2 ') 100 101 102 DO l=1,llm 103 DO ij=1,ip1jmp1 104 q(ij,l,iq)=zq(ij,l,iq) 105 ENDDO 106 DO ij=1,ip1jm+1,iip1 107 q(ij+iim,l,iq)=q(ij,l,iq) 108 ENDDO 109 ENDDO 110 ! ! CRisi: aussi pour les fils 111 do ifils=1,tracers(iq)%nqDescen 112 iq2=tracers(iq)%iqDescen(ifils) 113 DO l=1,llm 114 DO ij=1,ip1jmp1 115 q(ij,l,iq2)=zq(ij,l,iq2) 65 116 ENDDO 66 117 DO ij=1,ip1jm+1,iip1 118 q(ij+iim,l,iq2)=q(ij,l,iq2) 119 ENDDO 120 ENDDO 121 enddo 122 123 RETURN 124 END SUBROUTINE vlsplt 125 RECURSIVE SUBROUTINE vlx(q,pente_max,masse,u_m,iq) 126 USE infotrac, ONLY : nqtot,tracers, & ! CRisi 127 min_qParent,min_qMass,min_ratio ! MVals et CRisi 128 129 ! Auteurs: P.Le Van, F.Hourdin, F.Forget 130 ! 131 ! ******************************************************************** 132 ! Shema d'advection " pseudo amont " . 133 ! ******************************************************************** 134 ! nq,iq,q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... 135 ! 136 ! 137 ! -------------------------------------------------------------------- 138 IMPLICIT NONE 139 ! 140 include "dimensions.h" 141 include "paramet.h" 142 include "iniprint.h" 143 ! 144 ! 145 ! Arguments: 146 ! ---------- 147 REAL :: masse(ip1jmp1,llm,nqtot),pente_max 148 REAL :: u_m( ip1jmp1,llm ) 149 REAL :: q(ip1jmp1,llm,nqtot) 150 INTEGER :: iq ! CRisi 151 ! 152 ! Local 153 ! --------- 154 ! 155 INTEGER :: ij,l,j,i,iju,ijq,indu(ip1jmp1),niju 156 INTEGER :: n0,iadvplus(ip1jmp1,llm),nl(llm) 157 ! 158 REAL :: new_m,zu_m,zdum(ip1jmp1,llm) 159 ! REAL sigu(ip1jmp1) 160 REAL :: dxq(ip1jmp1,llm),dxqu(ip1jmp1) 161 REAL :: zz(ip1jmp1) 162 REAL :: adxqu(ip1jmp1),dxqmax(ip1jmp1,llm) 163 REAL :: u_mq(ip1jmp1,llm) 164 165 ! ! CRisi 166 REAL :: masseq(ip1jmp1,llm,nqtot),Ratio(ip1jmp1,llm,nqtot) 167 INTEGER :: ifils,iq2 ! CRisi 168 169 Logical :: first 170 SAVE first 171 DATA first/.true./ 172 173 ! calcul de la pente a droite et a gauche de la maille 174 175 176 IF (pente_max.gt.-1.e-5) THEN 177 ! IF (pente_max.gt.10) THEN 178 179 ! calcul des pentes avec limitation, Van Leer scheme I: 180 ! ----------------------------------------------------- 181 182 ! calcul de la pente aux points u 183 DO l = 1, llm 184 DO ij=iip2,ip1jm-1 185 dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq) 186 ENDDO 187 DO ij=iip1+iip1,ip1jm,iip1 188 dxqu(ij)=dxqu(ij-iim) 189 ! sigu(ij)=sigu(ij-iim) 190 ENDDO 191 192 DO ij=iip2,ip1jm 193 adxqu(ij)=abs(dxqu(ij)) 194 ENDDO 195 196 ! calcul de la pente maximum dans la maille en valeur absolue 197 198 DO ij=iip2+1,ip1jm 199 dxqmax(ij,l)=pente_max* & 200 min(adxqu(ij-1),adxqu(ij)) 201 ! limitation subtile 202 ! , min(adxqu(ij-1)/sigu(ij-1),adxqu(ij)/(1.-sigu(ij))) 203 204 205 ENDDO 206 207 DO ij=iip1+iip1,ip1jm,iip1 208 dxqmax(ij-iim,l)=dxqmax(ij,l) 209 ENDDO 210 211 DO ij=iip2+1,ip1jm 212 #ifdef CRAY 213 dxq(ij,l)= & 214 cvmgp(dxqu(ij-1)+dxqu(ij),0.,dxqu(ij-1)*dxqu(ij)) 215 #else 216 IF(dxqu(ij-1)*dxqu(ij).gt.0) THEN 217 dxq(ij,l)=dxqu(ij-1)+dxqu(ij) 218 ELSE 219 ! extremum local 220 dxq(ij,l)=0. 221 ENDIF 222 #endif 223 dxq(ij,l)=0.5*dxq(ij,l) 224 dxq(ij,l)= & 225 sign(min(abs(dxq(ij,l)),dxqmax(ij,l)),dxq(ij,l)) 226 ENDDO 227 228 ENDDO ! l=1,llm 229 !print*,'Ok calcul des pentes' 230 231 ELSE ! (pente_max.lt.-1.e-5) 232 233 ! Pentes produits: 234 ! ---------------- 235 236 DO l = 1, llm 237 DO ij=iip2,ip1jm-1 238 dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq) 239 ENDDO 240 DO ij=iip1+iip1,ip1jm,iip1 241 dxqu(ij)=dxqu(ij-iim) 242 ENDDO 243 244 DO ij=iip2+1,ip1jm 245 zz(ij)=dxqu(ij-1)*dxqu(ij) 246 zz(ij)=zz(ij)+zz(ij) 247 IF(zz(ij).gt.0) THEN 248 dxq(ij,l)=zz(ij)/(dxqu(ij-1)+dxqu(ij)) 249 ELSE 250 ! extremum local 251 dxq(ij,l)=0. 252 ENDIF 253 ENDDO 254 255 ENDDO 256 257 ENDIF ! (pente_max.lt.-1.e-5) 258 259 ! bouclage de la pente en iip1: 260 ! ----------------------------- 261 262 DO l=1,llm 263 DO ij=iip1+iip1,ip1jm,iip1 264 dxq(ij-iim,l)=dxq(ij,l) 265 ENDDO 266 DO ij=1,ip1jmp1 267 iadvplus(ij,l)=0 268 ENDDO 269 270 ENDDO 271 272 ! print*,'Bouclage en iip1' 273 274 ! calcul des flux a gauche et a droite 275 276 #ifdef CRAY 277 278 DO l=1,llm 279 DO ij=iip2,ip1jm-1 280 zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l,iq), & 281 1.+u_m(ij,l)/masse(ij+1,l,iq), & 282 u_m(ij,l)) 283 zdum(ij,l)=0.5*zdum(ij,l) 284 u_mq(ij,l)=cvmgp( & 285 q(ij,l,iq)+zdum(ij,l)*dxq(ij,l), & 286 q(ij+1,l,iq)-zdum(ij,l)*dxq(ij+1,l), & 287 u_m(ij,l)) 288 u_mq(ij,l)=u_m(ij,l)*u_mq(ij,l) 289 ENDDO 290 ENDDO 291 #else 292 ! on cumule le flux correspondant a toutes les mailles dont la masse 293 ! au travers de la paroi pENDant le pas de temps. 294 !print*,'Cumule ....' 295 296 DO l=1,llm 297 DO ij=iip2,ip1jm-1 298 ! print*,'masse(',ij,')=',masse(ij,l,iq) 299 IF (u_m(ij,l).gt.0.) THEN 300 zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l,iq) 301 u_mq(ij,l)=u_m(ij,l)*(q(ij,l,iq)+0.5*zdum(ij,l)*dxq(ij,l)) 302 ELSE 303 zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l,iq) 304 u_mq(ij,l)=u_m(ij,l)*(q(ij+1,l,iq) & 305 -0.5*zdum(ij,l)*dxq(ij+1,l)) 306 ENDIF 307 ENDDO 308 ENDDO 309 #endif 310 311 ! go to 9999 312 ! detection des points ou on advecte plus que la masse de la 313 ! maille 314 DO l=1,llm 315 DO ij=iip2,ip1jm-1 316 IF(zdum(ij,l).lt.0) THEN 317 iadvplus(ij,l)=1 318 u_mq(ij,l)=0. 319 ENDIF 320 ENDDO 321 ENDDO 322 !print*,'Ok test 1' 323 DO l=1,llm 324 DO ij=iip1+iip1,ip1jm,iip1 325 iadvplus(ij,l)=iadvplus(ij-iim,l) 326 ENDDO 327 ENDDO 328 ! print*,'Ok test 2' 329 330 331 ! traitement special pour le cas ou on advecte en longitude plus que le 332 ! contenu de la maille. 333 ! cette partie est mal vectorisee. 334 335 ! calcul du nombre de maille sur lequel on advecte plus que la maille. 336 337 n0=0 338 DO l=1,llm 339 nl(l)=0 340 DO ij=iip2,ip1jm 341 nl(l)=nl(l)+iadvplus(ij,l) 342 ENDDO 343 n0=n0+nl(l) 344 ENDDO 345 346 IF(n0.gt.0) THEN 347 if (prt_level > 2) PRINT *, & 348 'Nombre de points pour lesquels on advect plus que le' & 349 ,'contenu de la maille : ',n0 350 351 DO l=1,llm 352 IF(nl(l).gt.0) THEN 353 iju=0 354 ! indicage des mailles concernees par le traitement special 355 DO ij=iip2,ip1jm 356 IF(iadvplus(ij,l).eq.1.and.mod(ij,iip1).ne.0) THEN 357 iju=iju+1 358 indu(iju)=ij 359 ENDIF 360 ENDDO 361 niju=iju 362 ! PRINT*,'niju,nl',niju,nl(l) 363 364 ! traitement des mailles 365 DO iju=1,niju 366 ij=indu(iju) 367 j=(ij-1)/iip1+1 368 zu_m=u_m(ij,l) 369 u_mq(ij,l)=0. 370 IF(zu_m.gt.0.) THEN 371 ijq=ij 372 i=ijq-(j-1)*iip1 373 ! accumulation pour les mailles completements advectees 374 do while(zu_m.gt.masse(ijq,l,iq)) 375 u_mq(ij,l)=u_mq(ij,l)+q(ijq,l,iq) & 376 *masse(ijq,l,iq) 377 zu_m=zu_m-masse(ijq,l,iq) 378 i=mod(i-2+iim,iim)+1 379 ijq=(j-1)*iip1+i 380 ENDDO 381 ! ajout de la maille non completement advectee 382 u_mq(ij,l)=u_mq(ij,l)+zu_m* & 383 (q(ijq,l,iq)+0.5*(1.-zu_m/masse(ijq,l,iq)) & 384 *dxq(ijq,l)) 385 ELSE 386 ijq=ij+1 387 i=ijq-(j-1)*iip1 388 ! accumulation pour les mailles completements advectees 389 do while(-zu_m.gt.masse(ijq,l,iq)) 390 u_mq(ij,l)=u_mq(ij,l)-q(ijq,l,iq) & 391 *masse(ijq,l,iq) 392 zu_m=zu_m+masse(ijq,l,iq) 393 i=mod(i,iim)+1 394 ijq=(j-1)*iip1+i 395 ENDDO 396 ! ajout de la maille non completement advectee 397 u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l,iq)- & 398 0.5*(1.+zu_m/masse(ijq,l,iq))*dxq(ijq,l)) 399 ENDIF 400 ENDDO 401 ENDIF 402 ENDDO 403 ENDIF ! n0.gt.0 404 !9999 continue 405 406 407 ! bouclage en latitude 408 !print*,'cvant bouclage en latitude' 409 DO l=1,llm 410 DO ij=iip1+iip1,ip1jm,iip1 411 u_mq(ij,l)=u_mq(ij-iim,l) 412 ENDDO 413 ENDDO 414 415 ! CRisi: appel récursif de l'advection sur les fils. 416 ! Il faut faire ça avant d'avoir mis à jour q et masse 417 ! !write(*,*) 'vlsplt 326: iq,nqDesc(iq)=',iq,tracers(iq)%nqDescen 418 419 do ifils=1,tracers(iq)%nqDescen 420 iq2=tracers(iq)%iqDescen(ifils) 421 DO l=1,llm 422 DO ij=iip2,ip1jm 423 ! ! On a besoin de q et masse seulement entre iip2 et ip1jm 424 ! !masseq(ij,l,iq2)=masse(ij,l,iq)*q(ij,l,iq) 425 ! !Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq) 426 ! !Mvals: veiller a ce qu'on n'ait pas de denominateur nul 427 masseq(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass) 428 if (q(ij,l,iq).gt.min_qParent) then 429 Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq) 430 else 431 Ratio(ij,l,iq2)=min_ratio 432 endif 433 enddo 434 enddo 435 enddo 436 do ifils=1,tracers(iq)%nqChildren 437 iq2=tracers(iq)%iqDescen(ifils) 438 call vlx(Ratio,pente_max,masseq,u_mq,iq2) 439 enddo 440 ! end CRisi 441 442 443 ! calcul des tENDances 444 445 DO l=1,llm 446 DO ij=iip2+1,ip1jm 447 ! !MVals: veiller a ce qu'on ait pas de denominateur nul 448 new_m=max(masse(ij,l,iq)+u_m(ij-1,l)-u_m(ij,l),min_qMass) 449 q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+ & 450 u_mq(ij-1,l)-u_mq(ij,l)) & 451 /new_m 452 masse(ij,l,iq)=new_m 453 ENDDO 454 ! ModIF Fred 22 03 96 correction d'un bug (les scopy ci-dessous) 455 DO ij=iip1+iip1,ip1jm,iip1 456 q(ij-iim,l,iq)=q(ij,l,iq) 457 masse(ij-iim,l,iq)=masse(ij,l,iq) 458 ENDDO 459 ENDDO 460 461 ! ! retablir les fils en rapport de melange par rapport a l'air: 462 ! ! On calcule q entre iip2+1,ip1jm -> on fait pareil pour ratio 463 ! ! puis on boucle en longitude 464 do ifils=1,tracers(iq)%nqDescen 465 iq2=tracers(iq)%iqDescen(ifils) 466 DO l=1,llm 467 DO ij=iip2+1,ip1jm 468 q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2) 469 enddo 470 DO ij=iip1+iip1,ip1jm,iip1 471 q(ij-iim,l,iq2)=q(ij,l,iq2) 472 enddo ! DO ij=ijb+iip1-1,ije,iip1 473 enddo !DO l=1,llm 474 enddo 475 476 ! CALL SCOPY((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1) 477 ! CALL SCOPY((jjm-1)*llm,masse(iip1+iip1,1),iip1,masse(iip2,1),iip1) 478 479 480 RETURN 481 END SUBROUTINE vlx 482 RECURSIVE SUBROUTINE vly(q,pente_max,masse,masse_adv_v,iq) 483 USE infotrac, ONLY : nqtot,tracers, & ! CRisi 484 min_qParent,min_qMass,min_ratio ! MVals et CRisi 485 ! 486 ! Auteurs: P.Le Van, F.Hourdin, F.Forget 487 ! 488 ! ******************************************************************** 489 ! Shema d'advection " pseudo amont " . 490 ! ******************************************************************** 491 ! q,masse_adv_v,w sont des arguments d'entree pour le s-pg .... 492 ! dq sont des arguments de sortie pour le s-pg .... 493 ! 494 ! 495 ! -------------------------------------------------------------------- 496 USE comconst_mod, ONLY: pi 497 IMPLICIT NONE 498 ! 499 include "dimensions.h" 500 include "paramet.h" 501 include "comgeom.h" 502 ! 503 ! 504 ! Arguments: 505 ! ---------- 506 REAL :: masse(ip1jmp1,llm,nqtot),pente_max 507 REAL :: masse_adv_v( ip1jm,llm) 508 REAL :: q(ip1jmp1,llm,nqtot) 509 INTEGER :: iq ! CRisi 510 ! 511 ! Local 512 ! --------- 513 ! 514 INTEGER :: i,ij,l 515 ! 516 REAL :: airej2,airejjm,airescb(iim),airesch(iim) 517 REAL :: dyq(ip1jmp1,llm),dyqv(ip1jm) 518 REAL :: adyqv(ip1jm),dyqmax(ip1jmp1) 519 REAL :: qbyv(ip1jm,llm) 520 521 REAL :: qpns,qpsn,dyn1,dys1,dyn2,dys2,newmasse,fn,fs 522 ! REAL appn apps 523 ! REAL newq,oldmasse 524 LOGICAL :: first 525 SAVE first 526 527 REAL :: convpn,convps,convmpn,convmps 528 real :: massepn,masseps,qpn,qps 529 REAL :: sinlon(iip1),sinlondlon(iip1) 530 REAL :: coslon(iip1),coslondlon(iip1) 531 SAVE sinlon,coslon,sinlondlon,coslondlon 532 SAVE airej2,airejjm 533 534 REAL :: masseq(ip1jmp1,llm,nqtot),Ratio(ip1jmp1,llm,nqtot) ! CRisi 535 INTEGER :: ifils,iq2 ! CRisi 536 537 ! 538 ! 539 REAL :: SSUM 540 541 DATA first/.true./ 542 543 ! !write(*,*) 'vly 578: entree, iq=',iq 544 545 IF(first) THEN 546 PRINT*,'Shema Amont nouveau appele dans Vanleer ' 547 first=.false. 548 do i=2,iip1 549 coslon(i)=cos(rlonv(i)) 550 sinlon(i)=sin(rlonv(i)) 551 coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi 552 sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi 553 ENDDO 554 coslon(1)=coslon(iip1) 555 coslondlon(1)=coslondlon(iip1) 556 sinlon(1)=sinlon(iip1) 557 sinlondlon(1)=sinlondlon(iip1) 558 airej2 = SSUM( iim, aire(iip2), 1 ) 559 airejjm= SSUM( iim, aire(ip1jm -iim), 1 ) 560 ENDIF 561 562 ! 563 !PRINT*,'CALCUL EN LATITUDE' 564 565 DO l = 1, llm 566 ! 567 ! -------------------------------- 568 ! CALCUL EN LATITUDE 569 ! -------------------------------- 570 571 ! On commence par calculer la valeur du traceur moyenne sur le premier cercle 572 ! de latitude autour du pole (qpns pour le pole nord et qpsn pour 573 ! le pole nord) qui sera utilisee pour evaluer les pentes au pole. 574 575 DO i = 1, iim 576 airescb(i) = aire(i+ iip1) * q(i+ iip1,l,iq) 577 airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l,iq) 578 ENDDO 579 qpns = SSUM( iim, airescb ,1 ) / airej2 580 qpsn = SSUM( iim, airesch ,1 ) / airejjm 581 582 ! calcul des pentes aux points v 583 584 DO ij=1,ip1jm 585 dyqv(ij)=q(ij,l,iq)-q(ij+iip1,l,iq) 586 adyqv(ij)=abs(dyqv(ij)) 587 ENDDO 588 589 ! calcul des pentes aux points scalaires 590 591 DO ij=iip2,ip1jm 592 dyq(ij,l)=.5*(dyqv(ij-iip1)+dyqv(ij)) 593 dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij)) 594 dyqmax(ij)=pente_max*dyqmax(ij) 595 ENDDO 596 597 ! calcul des pentes aux poles 598 599 DO ij=1,iip1 600 dyq(ij,l)=qpns-q(ij+iip1,l,iq) 601 dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l,iq)-qpsn 602 ENDDO 603 604 ! filtrage de la derivee 605 dyn1=0. 606 dys1=0. 607 dyn2=0. 608 dys2=0. 609 DO ij=1,iim 610 dyn1=dyn1+sinlondlon(ij)*dyq(ij,l) 611 dys1=dys1+sinlondlon(ij)*dyq(ip1jm+ij,l) 612 dyn2=dyn2+coslondlon(ij)*dyq(ij,l) 613 dys2=dys2+coslondlon(ij)*dyq(ip1jm+ij,l) 614 ENDDO 615 DO ij=1,iip1 616 dyq(ij,l)=dyn1*sinlon(ij)+dyn2*coslon(ij) 617 dyq(ip1jm+ij,l)=dys1*sinlon(ij)+dys2*coslon(ij) 618 ENDDO 619 620 ! calcul des pentes limites aux poles 621 622 goto 8888 623 fn=1. 624 fs=1. 625 DO ij=1,iim 626 IF(pente_max*adyqv(ij).lt.abs(dyq(ij,l))) THEN 627 fn=min(pente_max*adyqv(ij)/abs(dyq(ij,l)),fn) 628 ENDIF 629 IF(pente_max*adyqv(ij+ip1jm-iip1).lt.abs(dyq(ij+ip1jm,l))) THEN 630 fs=min(pente_max*adyqv(ij+ip1jm-iip1)/abs(dyq(ij+ip1jm,l)),fs) 631 ENDIF 632 ENDDO 633 DO ij=1,iip1 634 dyq(ij,l)=fn*dyq(ij,l) 635 dyq(ip1jm+ij,l)=fs*dyq(ip1jm+ij,l) 636 ENDDO 637 8888 continue 638 DO ij=1,iip1 639 dyq(ij,l)=0. 640 dyq(ip1jm+ij,l)=0. 641 ENDDO 642 643 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 644 ! En memoire de dIFferents tests sur la 645 ! limitation des pentes aux poles. 646 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 647 ! PRINT*,dyq(1) 648 ! PRINT*,dyqv(iip1+1) 649 ! appn=abs(dyq(1)/dyqv(iip1+1)) 650 ! PRINT*,dyq(ip1jm+1) 651 ! PRINT*,dyqv(ip1jm-iip1+1) 652 ! apps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1)) 653 ! DO ij=2,iim 654 ! appn=amax1(abs(dyq(ij)/dyqv(ij)),appn) 655 ! apps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),apps) 656 ! ENDDO 657 ! appn=min(pente_max/appn,1.) 658 ! apps=min(pente_max/apps,1.) 659 ! 660 ! 661 ! cas ou on a un extremum au pole 662 ! 663 ! IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.) 664 ! & appn=0. 665 ! IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)* 666 ! & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.) 667 ! & apps=0. 668 ! 669 ! limitation des pentes aux poles 670 ! DO ij=1,iip1 671 ! dyq(ij)=appn*dyq(ij) 672 ! dyq(ip1jm+ij)=apps*dyq(ip1jm+ij) 673 ! ENDDO 674 ! 675 ! test 676 ! DO ij=1,iip1 677 ! dyq(iip1+ij)=0. 678 ! dyq(ip1jm+ij-iip1)=0. 679 ! ENDDO 680 ! DO ij=1,ip1jmp1 681 ! dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1)) 682 ! ENDDO 683 ! 684 ! changement 10 07 96 685 ! IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.) 686 ! & THEN 687 ! DO ij=1,iip1 688 ! dyqmax(ij)=0. 689 ! ENDDO 690 ! ELSE 691 ! DO ij=1,iip1 692 ! dyqmax(ij)=pente_max*abs(dyqv(ij)) 693 ! ENDDO 694 ! ENDIF 695 ! 696 ! IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)* 697 ! & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.) 698 ! &THEN 699 ! DO ij=ip1jm+1,ip1jmp1 700 ! dyqmax(ij)=0. 701 ! ENDDO 702 ! ELSE 703 ! DO ij=ip1jm+1,ip1jmp1 704 ! dyqmax(ij)=pente_max*abs(dyqv(ij-iip1)) 705 ! ENDDO 706 ! ENDIF 707 ! fin changement 10 07 96 708 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 709 710 ! calcul des pentes limitees 711 712 DO ij=iip2,ip1jm 713 IF(dyqv(ij)*dyqv(ij-iip1).gt.0.) THEN 714 dyq(ij,l)=sign(min(abs(dyq(ij,l)),dyqmax(ij)),dyq(ij,l)) 715 ELSE 716 dyq(ij,l)=0. 717 ENDIF 718 ENDDO 719 720 ENDDO 721 722 ! !write(*,*) 'vly 756' 723 DO l=1,llm 724 DO ij=1,ip1jm 725 IF(masse_adv_v(ij,l).gt.0) THEN 726 qbyv(ij,l)=q(ij+iip1,l,iq)+dyq(ij+iip1,l)* & 727 0.5*(1.-masse_adv_v(ij,l) & 728 /masse(ij+iip1,l,iq)) 729 ELSE 730 qbyv(ij,l)=q(ij,l,iq)-dyq(ij,l)* & 731 0.5*(1.+masse_adv_v(ij,l) & 732 /masse(ij,l,iq)) 733 ENDIF 734 qbyv(ij,l)=masse_adv_v(ij,l)*qbyv(ij,l) 735 ENDDO 736 ENDDO 737 738 ! CRisi: appel récursif de l'advection sur les fils. 739 ! Il faut faire ça avant d'avoir mis à jour q et masse 740 ! !write(*,*) 'vly 689: iq,nqDesc(iq)=',iq,tracers(iq)%nqDescen 741 742 do ifils=1,tracers(iq)%nqDescen 743 iq2=tracers(iq)%iqDescen(ifils) 744 DO l=1,llm 67 745 DO ij=1,ip1jmp1 68 mw(ij,llm+1)=0. 69 ENDDO 70 71 CALL SCOPY(ijp1llm,q(1,1,iq),1,zq(1,1,iq),1) 72 CALL SCOPY(ijp1llm,masse,1,zm(1,1,iq),1) 73 74 do ifils=1,tracers(iq)%nqDescen 75 iq2=tracers(iq)%iqDescen(ifils) 76 CALL SCOPY(ijp1llm,q(1,1,iq2),1,zq(1,1,iq2),1) 77 enddo 78 79 cprint*,'Entree vlx1' 80 c call minmaxq(zq,qmin,qmax,'avant vlx ') 81 call vlx(zq,pente_max,zm,mu,iq) 82 cprint*,'Sortie vlx1' 83 c call minmaxq(zq,qmin,qmax,'apres vlx1 ') 84 85 c print*,'Entree vly1' 86 87 call vly(zq,pente_max,zm,mv,iq) 88 c call minmaxq(zq,qmin,qmax,'apres vly1 ') 89 cprint*,'Sortie vly1' 90 call vlz(zq,pente_max,zm,mw,iq) 91 c call minmaxq(zq,qmin,qmax,'apres vlz ') 92 93 94 call vly(zq,pente_max,zm,mv,iq) 95 c call minmaxq(zq,qmin,qmax,'apres vly ') 96 97 98 call vlx(zq,pente_max,zm,mu,iq) 99 c call minmaxq(zq,qmin,qmax,'apres vlx2 ') 100 101 102 DO l=1,llm 103 DO ij=1,ip1jmp1 104 q(ij,l,iq)=zq(ij,l,iq) 105 ENDDO 106 DO ij=1,ip1jm+1,iip1 107 q(ij+iim,l,iq)=q(ij,l,iq) 108 ENDDO 109 ENDDO 110 ! CRisi: aussi pour les fils 111 do ifils=1,tracers(iq)%nqDescen 112 iq2=tracers(iq)%iqDescen(ifils) 113 DO l=1,llm 114 DO ij=1,ip1jmp1 115 q(ij,l,iq2)=zq(ij,l,iq2) 116 ENDDO 117 DO ij=1,ip1jm+1,iip1 118 q(ij+iim,l,iq2)=q(ij,l,iq2) 119 ENDDO 120 ENDDO 746 ! ! attention, chaque fils doit avoir son masseq, sinon, le 1er 747 ! ! fils ecrase le masseq de ses freres. 748 ! !masseq(ij,l,iq2)=masse(ij,l,iq)*q(ij,l,iq) 749 ! !Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq) 750 ! !MVals: veiller a ce qu'on n'ait pas de denominateur nul 751 masseq(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass) 752 if (q(ij,l,iq).gt.min_qParent) then 753 Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq) 754 else 755 Ratio(ij,l,iq2)=min_ratio 756 endif 121 757 enddo 122 123 RETURN 124 END 125 RECURSIVE SUBROUTINE vlx(q,pente_max,masse,u_m,iq) 126 USE infotrac, ONLY : nqtot,tracers, ! CRisi 127 & min_qParent,min_qMass,min_ratio ! MVals et CRisi 128 129 c Auteurs: P.Le Van, F.Hourdin, F.Forget 130 c 131 c ******************************************************************** 132 c Shema d'advection " pseudo amont " . 133 c ******************************************************************** 134 c nq,iq,q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... 135 c 136 c 137 c -------------------------------------------------------------------- 138 IMPLICIT NONE 139 c 140 include "dimensions.h" 141 include "paramet.h" 142 include "iniprint.h" 143 c 144 c 145 c Arguments: 146 c ---------- 147 REAL masse(ip1jmp1,llm,nqtot),pente_max 148 REAL u_m( ip1jmp1,llm ) 149 REAL q(ip1jmp1,llm,nqtot) 150 INTEGER iq ! CRisi 151 c 152 c Local 153 c --------- 154 c 155 INTEGER ij,l,j,i,iju,ijq,indu(ip1jmp1),niju 156 INTEGER n0,iadvplus(ip1jmp1,llm),nl(llm) 157 c 158 REAL new_m,zu_m,zdum(ip1jmp1,llm) 159 c REAL sigu(ip1jmp1) 160 REAL dxq(ip1jmp1,llm),dxqu(ip1jmp1) 161 REAL zz(ip1jmp1) 162 REAL adxqu(ip1jmp1),dxqmax(ip1jmp1,llm) 163 REAL u_mq(ip1jmp1,llm) 164 165 ! CRisi 166 REAL masseq(ip1jmp1,llm,nqtot),Ratio(ip1jmp1,llm,nqtot) 167 INTEGER ifils,iq2 ! CRisi 168 169 Logical first 170 SAVE first 171 DATA first/.true./ 172 173 c calcul de la pente a droite et a gauche de la maille 174 175 176 IF (pente_max.gt.-1.e-5) THEN 177 c IF (pente_max.gt.10) THEN 178 179 c calcul des pentes avec limitation, Van Leer scheme I: 180 c ----------------------------------------------------- 181 182 c calcul de la pente aux points u 183 DO l = 1, llm 184 DO ij=iip2,ip1jm-1 185 dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq) 186 ENDDO 187 DO ij=iip1+iip1,ip1jm,iip1 188 dxqu(ij)=dxqu(ij-iim) 189 c sigu(ij)=sigu(ij-iim) 190 ENDDO 191 192 DO ij=iip2,ip1jm 193 adxqu(ij)=abs(dxqu(ij)) 194 ENDDO 195 196 c calcul de la pente maximum dans la maille en valeur absolue 197 198 DO ij=iip2+1,ip1jm 199 dxqmax(ij,l)=pente_max* 200 , min(adxqu(ij-1),adxqu(ij)) 201 c limitation subtile 202 c , min(adxqu(ij-1)/sigu(ij-1),adxqu(ij)/(1.-sigu(ij))) 203 204 205 ENDDO 206 207 DO ij=iip1+iip1,ip1jm,iip1 208 dxqmax(ij-iim,l)=dxqmax(ij,l) 209 ENDDO 210 211 DO ij=iip2+1,ip1jm 758 enddo 759 enddo 760 761 do ifils=1,tracers(iq)%nqDescen 762 iq2=tracers(iq)%iqDescen(ifils) 763 call vly(Ratio,pente_max,masseq,qbyv,iq2) 764 enddo 765 766 DO l=1,llm 767 DO ij=iip2,ip1jm 768 newmasse=masse(ij,l,iq) & 769 +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l) 770 q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+qbyv(ij,l) & 771 -qbyv(ij-iip1,l))/newmasse 772 masse(ij,l,iq)=newmasse 773 ENDDO 774 !.-. ancienne version 775 ! convpn=SSUM(iim,qbyv(1,l),1)/apoln 776 ! convmpn=ssum(iim,masse_adv_v(1,l),1)/apoln 777 778 convpn=SSUM(iim,qbyv(1,l),1) 779 convmpn=ssum(iim,masse_adv_v(1,l),1) 780 massepn=ssum(iim,masse(1,l,iq),1) 781 qpn=0. 782 do ij=1,iim 783 qpn=qpn+masse(ij,l,iq)*q(ij,l,iq) 784 enddo 785 qpn=(qpn+convpn)/(massepn+convmpn) 786 do ij=1,iip1 787 q(ij,l,iq)=qpn 788 enddo 789 790 ! convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)/apols 791 ! convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)/apols 792 793 convps=-SSUM(iim,qbyv(ip1jm-iim,l),1) 794 convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1) 795 masseps=ssum(iim, masse(ip1jm+1,l,iq),1) 796 qps=0. 797 do ij = ip1jm+1,ip1jmp1-1 798 qps=qps+masse(ij,l,iq)*q(ij,l,iq) 799 enddo 800 qps=(qps+convps)/(masseps+convmps) 801 do ij=ip1jm+1,ip1jmp1 802 q(ij,l,iq)=qps 803 enddo 804 805 !.-. fin ancienne version 806 807 !._. nouvelle version 808 ! convpn=SSUM(iim,qbyv(1,l),1) 809 ! convmpn=ssum(iim,masse_adv_v(1,l),1) 810 ! oldmasse=ssum(iim,masse(1,l),1) 811 ! newmasse=oldmasse+convmpn 812 ! newq=(q(1,l)*oldmasse+convpn)/newmasse 813 ! newmasse=newmasse/apoln 814 ! DO ij = 1,iip1 815 ! q(ij,l)=newq 816 ! masse(ij,l,iq)=newmasse*aire(ij) 817 ! ENDDO 818 ! convps=-SSUM(iim,qbyv(ip1jm-iim,l),1) 819 ! convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1) 820 ! oldmasse=ssum(iim,masse(ip1jm-iim,l),1) 821 ! newmasse=oldmasse+convmps 822 ! newq=(q(ip1jmp1,l)*oldmasse+convps)/newmasse 823 ! newmasse=newmasse/apols 824 ! DO ij = ip1jm+1,ip1jmp1 825 ! q(ij,l)=newq 826 ! masse(ij,l,iq)=newmasse*aire(ij) 827 ! ENDDO 828 !._. fin nouvelle version 829 ENDDO 830 831 ! retablir les fils en rapport de melange par rapport a l'air: 832 do ifils=1,tracers(iq)%nqDescen 833 iq2=tracers(iq)%iqDescen(ifils) 834 DO l=1,llm 835 DO ij=1,ip1jmp1 836 q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2) 837 enddo 838 enddo 839 enddo 840 841 ! !write(*,*) 'vly 853: sortie' 842 843 RETURN 844 END SUBROUTINE vly 845 RECURSIVE SUBROUTINE vlz(q,pente_max,masse,w,iq) 846 USE infotrac, ONLY : nqtot,tracers, & ! CRisi 847 min_qParent,min_qMass,min_ratio ! MVals et CRisi 848 ! 849 ! Auteurs: P.Le Van, F.Hourdin, F.Forget 850 ! 851 ! ******************************************************************** 852 ! Shema d'advection " pseudo amont " . 853 ! ******************************************************************** 854 ! q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... 855 ! dq sont des arguments de sortie pour le s-pg .... 856 ! 857 ! 858 ! -------------------------------------------------------------------- 859 IMPLICIT NONE 860 ! 861 include "dimensions.h" 862 include "paramet.h" 863 ! 864 ! 865 ! Arguments: 866 ! ---------- 867 REAL :: masse(ip1jmp1,llm,nqtot),pente_max 868 REAL :: q(ip1jmp1,llm,nqtot) 869 REAL :: w(ip1jmp1,llm+1) 870 INTEGER :: iq 871 ! 872 ! Local 873 ! --------- 874 ! 875 INTEGER :: ij,l 876 ! 877 REAL :: wq(ip1jmp1,llm+1),newmasse 878 879 REAL :: dzq(ip1jmp1,llm),dzqw(ip1jmp1,llm),adzqw(ip1jmp1,llm),dzqmax 880 REAL :: sigw 881 882 REAL :: masseq(ip1jmp1,llm,nqtot),Ratio(ip1jmp1,llm,nqtot) ! CRisi 883 INTEGER :: ifils,iq2 ! CRisi 884 885 LOGICAL :: testcpu 886 SAVE testcpu 887 888 #ifdef BIDON 889 REAL :: temps0,temps1,second 890 SAVE temps0,temps1 891 892 DATA testcpu/.false./ 893 DATA temps0,temps1/0.,0./ 894 #endif 895 896 ! On oriente tout dans le sens de la pression c'est a dire dans le 897 ! sens de W 898 899 ! !write(*,*) 'vlz 923: entree' 900 901 #ifdef BIDON 902 IF(testcpu) THEN 903 temps0=second(0.) 904 ENDIF 905 #endif 906 DO l=2,llm 907 DO ij=1,ip1jmp1 908 dzqw(ij,l)=q(ij,l-1,iq)-q(ij,l,iq) 909 adzqw(ij,l)=abs(dzqw(ij,l)) 910 ENDDO 911 ENDDO 912 913 DO l=2,llm-1 914 DO ij=1,ip1jmp1 212 915 #ifdef CRAY 213 dxq(ij,l)=214 , cvmgp(dxqu(ij-1)+dxqu(ij),0.,dxqu(ij-1)*dxqu(ij))916 dzq(ij,l)=0.5* & 917 cvmgp(dzqw(ij,l)+dzqw(ij,l+1),0.,dzqw(ij,l)*dzqw(ij,l+1)) 215 918 #else 216 IF(dxqu(ij-1)*dxqu(ij).gt.0) THEN 217 dxq(ij,l)=dxqu(ij-1)+dxqu(ij) 218 ELSE 219 c extremum local 220 dxq(ij,l)=0. 221 ENDIF 919 IF(dzqw(ij,l)*dzqw(ij,l+1).gt.0.) THEN 920 dzq(ij,l)=0.5*(dzqw(ij,l)+dzqw(ij,l+1)) 921 ELSE 922 dzq(ij,l)=0. 923 ENDIF 222 924 #endif 223 dxq(ij,l)=0.5*dxq(ij,l) 224 dxq(ij,l)= 225 , sign(min(abs(dxq(ij,l)),dxqmax(ij,l)),dxq(ij,l)) 226 ENDDO 227 228 ENDDO ! l=1,llm 229 cprint*,'Ok calcul des pentes' 230 231 ELSE ! (pente_max.lt.-1.e-5) 232 233 c Pentes produits: 234 c ---------------- 235 236 DO l = 1, llm 237 DO ij=iip2,ip1jm-1 238 dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq) 239 ENDDO 240 DO ij=iip1+iip1,ip1jm,iip1 241 dxqu(ij)=dxqu(ij-iim) 242 ENDDO 243 244 DO ij=iip2+1,ip1jm 245 zz(ij)=dxqu(ij-1)*dxqu(ij) 246 zz(ij)=zz(ij)+zz(ij) 247 IF(zz(ij).gt.0) THEN 248 dxq(ij,l)=zz(ij)/(dxqu(ij-1)+dxqu(ij)) 249 ELSE 250 c extremum local 251 dxq(ij,l)=0. 252 ENDIF 253 ENDDO 254 255 ENDDO 256 257 ENDIF ! (pente_max.lt.-1.e-5) 258 259 c bouclage de la pente en iip1: 260 c ----------------------------- 261 262 DO l=1,llm 263 DO ij=iip1+iip1,ip1jm,iip1 264 dxq(ij-iim,l)=dxq(ij,l) 265 ENDDO 266 DO ij=1,ip1jmp1 267 iadvplus(ij,l)=0 268 ENDDO 269 270 ENDDO 271 272 c print*,'Bouclage en iip1' 273 274 c calcul des flux a gauche et a droite 275 276 #ifdef CRAY 277 278 DO l=1,llm 279 DO ij=iip2,ip1jm-1 280 zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l,iq), 281 , 1.+u_m(ij,l)/masse(ij+1,l,iq), 282 , u_m(ij,l)) 283 zdum(ij,l)=0.5*zdum(ij,l) 284 u_mq(ij,l)=cvmgp( 285 , q(ij,l,iq)+zdum(ij,l)*dxq(ij,l), 286 , q(ij+1,l,iq)-zdum(ij,l)*dxq(ij+1,l), 287 , u_m(ij,l)) 288 u_mq(ij,l)=u_m(ij,l)*u_mq(ij,l) 289 ENDDO 290 ENDDO 291 #else 292 c on cumule le flux correspondant a toutes les mailles dont la masse 293 c au travers de la paroi pENDant le pas de temps. 294 cprint*,'Cumule ....' 295 296 DO l=1,llm 297 DO ij=iip2,ip1jm-1 298 c print*,'masse(',ij,')=',masse(ij,l,iq) 299 IF (u_m(ij,l).gt.0.) THEN 300 zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l,iq) 301 u_mq(ij,l)=u_m(ij,l)*(q(ij,l,iq)+0.5*zdum(ij,l)*dxq(ij,l)) 302 ELSE 303 zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l,iq) 304 u_mq(ij,l)=u_m(ij,l)*(q(ij+1,l,iq) 305 & -0.5*zdum(ij,l)*dxq(ij+1,l)) 306 ENDIF 307 ENDDO 308 ENDDO 925 dzqmax=pente_max*min(adzqw(ij,l),adzqw(ij,l+1)) 926 dzq(ij,l)=sign(min(abs(dzq(ij,l)),dzqmax),dzq(ij,l)) 927 ENDDO 928 ENDDO 929 930 ! !write(*,*) 'vlz 954' 931 DO ij=1,ip1jmp1 932 dzq(ij,1)=0. 933 dzq(ij,llm)=0. 934 ENDDO 935 936 #ifdef BIDON 937 IF(testcpu) THEN 938 temps1=temps1+second(0.)-temps0 939 ENDIF 309 940 #endif 310 311 c go to 9999 312 c detection des points ou on advecte plus que la masse de la 313 c maille 314 DO l=1,llm 315 DO ij=iip2,ip1jm-1 316 IF(zdum(ij,l).lt.0) THEN 317 iadvplus(ij,l)=1 318 u_mq(ij,l)=0. 319 ENDIF 320 ENDDO 321 ENDDO 322 cprint*,'Ok test 1' 323 DO l=1,llm 324 DO ij=iip1+iip1,ip1jm,iip1 325 iadvplus(ij,l)=iadvplus(ij-iim,l) 326 ENDDO 327 ENDDO 328 c print*,'Ok test 2' 329 330 331 c traitement special pour le cas ou on advecte en longitude plus que le 332 c contenu de la maille. 333 c cette partie est mal vectorisee. 334 335 c calcul du nombre de maille sur lequel on advecte plus que la maille. 336 337 n0=0 338 DO l=1,llm 339 nl(l)=0 340 DO ij=iip2,ip1jm 341 nl(l)=nl(l)+iadvplus(ij,l) 342 ENDDO 343 n0=n0+nl(l) 344 ENDDO 345 346 IF(n0.gt.0) THEN 347 if (prt_level > 2) PRINT *, 348 $ 'Nombre de points pour lesquels on advect plus que le' 349 & ,'contenu de la maille : ',n0 350 351 DO l=1,llm 352 IF(nl(l).gt.0) THEN 353 iju=0 354 c indicage des mailles concernees par le traitement special 355 DO ij=iip2,ip1jm 356 IF(iadvplus(ij,l).eq.1.and.mod(ij,iip1).ne.0) THEN 357 iju=iju+1 358 indu(iju)=ij 359 ENDIF 360 ENDDO 361 niju=iju 362 c PRINT*,'niju,nl',niju,nl(l) 363 364 c traitement des mailles 365 DO iju=1,niju 366 ij=indu(iju) 367 j=(ij-1)/iip1+1 368 zu_m=u_m(ij,l) 369 u_mq(ij,l)=0. 370 IF(zu_m.gt.0.) THEN 371 ijq=ij 372 i=ijq-(j-1)*iip1 373 c accumulation pour les mailles completements advectees 374 do while(zu_m.gt.masse(ijq,l,iq)) 375 u_mq(ij,l)=u_mq(ij,l)+q(ijq,l,iq) 376 & *masse(ijq,l,iq) 377 zu_m=zu_m-masse(ijq,l,iq) 378 i=mod(i-2+iim,iim)+1 379 ijq=(j-1)*iip1+i 380 ENDDO 381 c ajout de la maille non completement advectee 382 u_mq(ij,l)=u_mq(ij,l)+zu_m* 383 & (q(ijq,l,iq)+0.5*(1.-zu_m/masse(ijq,l,iq)) 384 & *dxq(ijq,l)) 385 ELSE 386 ijq=ij+1 387 i=ijq-(j-1)*iip1 388 c accumulation pour les mailles completements advectees 389 do while(-zu_m.gt.masse(ijq,l,iq)) 390 u_mq(ij,l)=u_mq(ij,l)-q(ijq,l,iq) 391 & *masse(ijq,l,iq) 392 zu_m=zu_m+masse(ijq,l,iq) 393 i=mod(i,iim)+1 394 ijq=(j-1)*iip1+i 395 ENDDO 396 c ajout de la maille non completement advectee 397 u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l,iq)- 398 & 0.5*(1.+zu_m/masse(ijq,l,iq))*dxq(ijq,l)) 399 ENDIF 400 ENDDO 401 ENDIF 402 ENDDO 403 ENDIF ! n0.gt.0 404 c9999 continue 405 406 407 c bouclage en latitude 408 cprint*,'cvant bouclage en latitude' 409 DO l=1,llm 410 DO ij=iip1+iip1,ip1jm,iip1 411 u_mq(ij,l)=u_mq(ij-iim,l) 412 ENDDO 413 ENDDO 414 415 ! CRisi: appel récursif de l'advection sur les fils. 416 ! Il faut faire ça avant d'avoir mis à jour q et masse 417 !write(*,*) 'vlsplt 326: iq,nqDesc(iq)=',iq,tracers(iq)%nqDescen 418 419 do ifils=1,tracers(iq)%nqDescen 420 iq2=tracers(iq)%iqDescen(ifils) 421 DO l=1,llm 422 DO ij=iip2,ip1jm 423 ! On a besoin de q et masse seulement entre iip2 et ip1jm 424 !masseq(ij,l,iq2)=masse(ij,l,iq)*q(ij,l,iq) 425 !Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq) 426 !Mvals: veiller a ce qu'on n'ait pas de denominateur nul 427 masseq(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass) 428 if (q(ij,l,iq).gt.min_qParent) then 429 Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq) 430 else 431 Ratio(ij,l,iq2)=min_ratio 432 endif 433 enddo 434 enddo 941 ! --------------------------------------------------------------- 942 ! .... calcul des termes d'advection verticale ....... 943 ! --------------------------------------------------------------- 944 945 ! calcul de - d( q * w )/ d(sigma) qu'on ajoute a dq pour calculer dq 946 947 ! !write(*,*) 'vlz 969' 948 DO l = 1,llm-1 949 do ij = 1,ip1jmp1 950 IF(w(ij,l+1).gt.0.) THEN 951 sigw=w(ij,l+1)/masse(ij,l+1,iq) 952 wq(ij,l+1)=w(ij,l+1)*(q(ij,l+1,iq) & 953 +0.5*(1.-sigw)*dzq(ij,l+1)) 954 ELSE 955 sigw=w(ij,l+1)/masse(ij,l,iq) 956 wq(ij,l+1)=w(ij,l+1)*(q(ij,l,iq)-0.5*(1.+sigw)*dzq(ij,l)) 957 ENDIF 958 ENDDO 959 ENDDO 960 961 DO ij=1,ip1jmp1 962 wq(ij,llm+1)=0. 963 wq(ij,1)=0. 964 ENDDO 965 966 ! CRisi: appel récursif de l'advection sur les fils. 967 ! Il faut faire ça avant d'avoir mis à jour q et masse 968 ! !write(*,*) 'vlsplt 942: iq,nqChildren(iq)=',iq,nqChildren(iq) 969 do ifils=1,tracers(iq)%nqDescen 970 iq2=tracers(iq)%iqDescen(ifils) 971 DO l=1,llm 972 DO ij=1,ip1jmp1 973 ! !masseq(ij,l,iq2)=masse(ij,l,iq)*q(ij,l,iq) 974 ! !Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq) 975 ! !MVals: veiller a ce qu'on n'ait pas de denominateur nul 976 masseq(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass) 977 if (q(ij,l,iq).gt.min_qParent) then 978 Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq) 979 else 980 Ratio(ij,l,iq2)=min_ratio 981 endif 435 982 enddo 436 do ifils=1,tracers(iq)%nqChildren 437 iq2=tracers(iq)%iqDescen(ifils) 438 call vlx(Ratio,pente_max,masseq,u_mq,iq2) 983 enddo 984 enddo 985 986 do ifils=1,tracers(iq)%nqChildren 987 iq2=tracers(iq)%iqDescen(ifils) 988 call vlz(Ratio,pente_max,masseq,wq,iq2) 989 enddo 990 ! end CRisi 991 992 DO l=1,llm 993 DO ij=1,ip1jmp1 994 newmasse=masse(ij,l,iq)+w(ij,l+1)-w(ij,l) 995 q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+wq(ij,l+1)-wq(ij,l)) & 996 /newmasse 997 masse(ij,l,iq)=newmasse 998 ENDDO 999 ENDDO 1000 1001 ! retablir les fils en rapport de melange par rapport a l'air: 1002 do ifils=1,tracers(iq)%nqDescen 1003 iq2=tracers(iq)%iqDescen(ifils) 1004 DO l=1,llm 1005 DO ij=1,ip1jmp1 1006 q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2) 439 1007 enddo 440 ! end CRisi 441 442 443 c calcul des tENDances 444 445 DO l=1,llm 446 DO ij=iip2+1,ip1jm 447 !MVals: veiller a ce qu'on ait pas de denominateur nul 448 new_m=max(masse(ij,l,iq)+u_m(ij-1,l)-u_m(ij,l),min_qMass) 449 q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+ 450 & u_mq(ij-1,l)-u_mq(ij,l)) 451 & /new_m 452 masse(ij,l,iq)=new_m 453 ENDDO 454 c ModIF Fred 22 03 96 correction d'un bug (les scopy ci-dessous) 455 DO ij=iip1+iip1,ip1jm,iip1 456 q(ij-iim,l,iq)=q(ij,l,iq) 457 masse(ij-iim,l,iq)=masse(ij,l,iq) 458 ENDDO 459 ENDDO 460 461 ! retablir les fils en rapport de melange par rapport a l'air: 462 ! On calcule q entre iip2+1,ip1jm -> on fait pareil pour ratio 463 ! puis on boucle en longitude 464 do ifils=1,tracers(iq)%nqDescen 465 iq2=tracers(iq)%iqDescen(ifils) 466 DO l=1,llm 467 DO ij=iip2+1,ip1jm 468 q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2) 469 enddo 470 DO ij=iip1+iip1,ip1jm,iip1 471 q(ij-iim,l,iq2)=q(ij,l,iq2) 472 enddo ! DO ij=ijb+iip1-1,ije,iip1 473 enddo !DO l=1,llm 474 enddo 475 476 c CALL SCOPY((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1) 477 c CALL SCOPY((jjm-1)*llm,masse(iip1+iip1,1),iip1,masse(iip2,1),iip1) 478 479 480 RETURN 481 END 482 RECURSIVE SUBROUTINE vly(q,pente_max,masse,masse_adv_v,iq) 483 USE infotrac, ONLY : nqtot,tracers, ! CRisi 484 & min_qParent,min_qMass,min_ratio ! MVals et CRisi 485 c 486 c Auteurs: P.Le Van, F.Hourdin, F.Forget 487 c 488 c ******************************************************************** 489 c Shema d'advection " pseudo amont " . 490 c ******************************************************************** 491 c q,masse_adv_v,w sont des arguments d'entree pour le s-pg .... 492 c dq sont des arguments de sortie pour le s-pg .... 493 c 494 c 495 c -------------------------------------------------------------------- 496 USE comconst_mod, ONLY: pi 497 IMPLICIT NONE 498 c 499 include "dimensions.h" 500 include "paramet.h" 501 include "comgeom.h" 502 c 503 c 504 c Arguments: 505 c ---------- 506 REAL masse(ip1jmp1,llm,nqtot),pente_max 507 REAL masse_adv_v( ip1jm,llm) 508 REAL q(ip1jmp1,llm,nqtot) 509 INTEGER iq ! CRisi 510 c 511 c Local 512 c --------- 513 c 514 INTEGER i,ij,l 515 c 516 REAL airej2,airejjm,airescb(iim),airesch(iim) 517 REAL dyq(ip1jmp1,llm),dyqv(ip1jm) 518 REAL adyqv(ip1jm),dyqmax(ip1jmp1) 519 REAL qbyv(ip1jm,llm) 520 521 REAL qpns,qpsn,dyn1,dys1,dyn2,dys2,newmasse,fn,fs 522 c REAL appn apps 523 c REAL newq,oldmasse 524 LOGICAL first 525 SAVE first 526 527 REAL convpn,convps,convmpn,convmps 528 real massepn,masseps,qpn,qps 529 REAL sinlon(iip1),sinlondlon(iip1) 530 REAL coslon(iip1),coslondlon(iip1) 531 SAVE sinlon,coslon,sinlondlon,coslondlon 532 SAVE airej2,airejjm 533 534 REAL masseq(ip1jmp1,llm,nqtot),Ratio(ip1jmp1,llm,nqtot) ! CRisi 535 INTEGER ifils,iq2 ! CRisi 536 537 c 538 c 539 REAL SSUM 540 541 DATA first/.true./ 542 543 !write(*,*) 'vly 578: entree, iq=',iq 544 545 IF(first) THEN 546 PRINT*,'Shema Amont nouveau appele dans Vanleer ' 547 first=.false. 548 do i=2,iip1 549 coslon(i)=cos(rlonv(i)) 550 sinlon(i)=sin(rlonv(i)) 551 coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi 552 sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi 553 ENDDO 554 coslon(1)=coslon(iip1) 555 coslondlon(1)=coslondlon(iip1) 556 sinlon(1)=sinlon(iip1) 557 sinlondlon(1)=sinlondlon(iip1) 558 airej2 = SSUM( iim, aire(iip2), 1 ) 559 airejjm= SSUM( iim, aire(ip1jm -iim), 1 ) 560 ENDIF 561 562 c 563 cPRINT*,'CALCUL EN LATITUDE' 564 565 DO l = 1, llm 566 c 567 c -------------------------------- 568 c CALCUL EN LATITUDE 569 c -------------------------------- 570 571 c On commence par calculer la valeur du traceur moyenne sur le premier cercle 572 c de latitude autour du pole (qpns pour le pole nord et qpsn pour 573 c le pole nord) qui sera utilisee pour evaluer les pentes au pole. 574 575 DO i = 1, iim 576 airescb(i) = aire(i+ iip1) * q(i+ iip1,l,iq) 577 airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l,iq) 578 ENDDO 579 qpns = SSUM( iim, airescb ,1 ) / airej2 580 qpsn = SSUM( iim, airesch ,1 ) / airejjm 581 582 c calcul des pentes aux points v 583 584 DO ij=1,ip1jm 585 dyqv(ij)=q(ij,l,iq)-q(ij+iip1,l,iq) 586 adyqv(ij)=abs(dyqv(ij)) 587 ENDDO 588 589 c calcul des pentes aux points scalaires 590 591 DO ij=iip2,ip1jm 592 dyq(ij,l)=.5*(dyqv(ij-iip1)+dyqv(ij)) 593 dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij)) 594 dyqmax(ij)=pente_max*dyqmax(ij) 595 ENDDO 596 597 c calcul des pentes aux poles 598 599 DO ij=1,iip1 600 dyq(ij,l)=qpns-q(ij+iip1,l,iq) 601 dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l,iq)-qpsn 602 ENDDO 603 604 c filtrage de la derivee 605 dyn1=0. 606 dys1=0. 607 dyn2=0. 608 dys2=0. 609 DO ij=1,iim 610 dyn1=dyn1+sinlondlon(ij)*dyq(ij,l) 611 dys1=dys1+sinlondlon(ij)*dyq(ip1jm+ij,l) 612 dyn2=dyn2+coslondlon(ij)*dyq(ij,l) 613 dys2=dys2+coslondlon(ij)*dyq(ip1jm+ij,l) 614 ENDDO 615 DO ij=1,iip1 616 dyq(ij,l)=dyn1*sinlon(ij)+dyn2*coslon(ij) 617 dyq(ip1jm+ij,l)=dys1*sinlon(ij)+dys2*coslon(ij) 618 ENDDO 619 620 c calcul des pentes limites aux poles 621 622 goto 8888 623 fn=1. 624 fs=1. 625 DO ij=1,iim 626 IF(pente_max*adyqv(ij).lt.abs(dyq(ij,l))) THEN 627 fn=min(pente_max*adyqv(ij)/abs(dyq(ij,l)),fn) 628 ENDIF 629 IF(pente_max*adyqv(ij+ip1jm-iip1).lt.abs(dyq(ij+ip1jm,l))) THEN 630 fs=min(pente_max*adyqv(ij+ip1jm-iip1)/abs(dyq(ij+ip1jm,l)),fs) 631 ENDIF 632 ENDDO 633 DO ij=1,iip1 634 dyq(ij,l)=fn*dyq(ij,l) 635 dyq(ip1jm+ij,l)=fs*dyq(ip1jm+ij,l) 636 ENDDO 637 8888 continue 638 DO ij=1,iip1 639 dyq(ij,l)=0. 640 dyq(ip1jm+ij,l)=0. 641 ENDDO 642 643 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 644 C En memoire de dIFferents tests sur la 645 C limitation des pentes aux poles. 646 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 647 C PRINT*,dyq(1) 648 C PRINT*,dyqv(iip1+1) 649 C appn=abs(dyq(1)/dyqv(iip1+1)) 650 C PRINT*,dyq(ip1jm+1) 651 C PRINT*,dyqv(ip1jm-iip1+1) 652 C apps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1)) 653 C DO ij=2,iim 654 C appn=amax1(abs(dyq(ij)/dyqv(ij)),appn) 655 C apps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),apps) 656 C ENDDO 657 C appn=min(pente_max/appn,1.) 658 C apps=min(pente_max/apps,1.) 659 C 660 C 661 C cas ou on a un extremum au pole 662 C 663 C IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.) 664 C & appn=0. 665 C IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)* 666 C & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.) 667 C & apps=0. 668 C 669 C limitation des pentes aux poles 670 C DO ij=1,iip1 671 C dyq(ij)=appn*dyq(ij) 672 C dyq(ip1jm+ij)=apps*dyq(ip1jm+ij) 673 C ENDDO 674 C 675 C test 676 C DO ij=1,iip1 677 C dyq(iip1+ij)=0. 678 C dyq(ip1jm+ij-iip1)=0. 679 C ENDDO 680 C DO ij=1,ip1jmp1 681 C dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1)) 682 C ENDDO 683 C 684 C changement 10 07 96 685 C IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.) 686 C & THEN 687 C DO ij=1,iip1 688 C dyqmax(ij)=0. 689 C ENDDO 690 C ELSE 691 C DO ij=1,iip1 692 C dyqmax(ij)=pente_max*abs(dyqv(ij)) 693 C ENDDO 694 C ENDIF 695 C 696 C IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)* 697 C & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.) 698 C &THEN 699 C DO ij=ip1jm+1,ip1jmp1 700 C dyqmax(ij)=0. 701 C ENDDO 702 C ELSE 703 C DO ij=ip1jm+1,ip1jmp1 704 C dyqmax(ij)=pente_max*abs(dyqv(ij-iip1)) 705 C ENDDO 706 C ENDIF 707 C fin changement 10 07 96 708 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 709 710 c calcul des pentes limitees 711 712 DO ij=iip2,ip1jm 713 IF(dyqv(ij)*dyqv(ij-iip1).gt.0.) THEN 714 dyq(ij,l)=sign(min(abs(dyq(ij,l)),dyqmax(ij)),dyq(ij,l)) 715 ELSE 716 dyq(ij,l)=0. 717 ENDIF 718 ENDDO 719 720 ENDDO 721 722 !write(*,*) 'vly 756' 723 DO l=1,llm 724 DO ij=1,ip1jm 725 IF(masse_adv_v(ij,l).gt.0) THEN 726 qbyv(ij,l)=q(ij+iip1,l,iq)+dyq(ij+iip1,l)* 727 , 0.5*(1.-masse_adv_v(ij,l) 728 , /masse(ij+iip1,l,iq)) 729 ELSE 730 qbyv(ij,l)=q(ij,l,iq)-dyq(ij,l)* 731 , 0.5*(1.+masse_adv_v(ij,l) 732 , /masse(ij,l,iq)) 733 ENDIF 734 qbyv(ij,l)=masse_adv_v(ij,l)*qbyv(ij,l) 735 ENDDO 736 ENDDO 737 738 ! CRisi: appel récursif de l'advection sur les fils. 739 ! Il faut faire ça avant d'avoir mis à jour q et masse 740 !write(*,*) 'vly 689: iq,nqDesc(iq)=',iq,tracers(iq)%nqDescen 741 742 do ifils=1,tracers(iq)%nqDescen 743 iq2=tracers(iq)%iqDescen(ifils) 744 DO l=1,llm 745 DO ij=1,ip1jmp1 746 ! attention, chaque fils doit avoir son masseq, sinon, le 1er 747 ! fils ecrase le masseq de ses freres. 748 !masseq(ij,l,iq2)=masse(ij,l,iq)*q(ij,l,iq) 749 !Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq) 750 !MVals: veiller a ce qu'on n'ait pas de denominateur nul 751 masseq(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass) 752 if (q(ij,l,iq).gt.min_qParent) then 753 Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq) 754 else 755 Ratio(ij,l,iq2)=min_ratio 756 endif 757 enddo 758 enddo 759 enddo 760 761 do ifils=1,tracers(iq)%nqDescen 762 iq2=tracers(iq)%iqDescen(ifils) 763 call vly(Ratio,pente_max,masseq,qbyv,iq2) 764 enddo 765 766 DO l=1,llm 767 DO ij=iip2,ip1jm 768 newmasse=masse(ij,l,iq) 769 & +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l) 770 q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+qbyv(ij,l) 771 & -qbyv(ij-iip1,l))/newmasse 772 masse(ij,l,iq)=newmasse 773 ENDDO 774 c.-. ancienne version 775 c convpn=SSUM(iim,qbyv(1,l),1)/apoln 776 c convmpn=ssum(iim,masse_adv_v(1,l),1)/apoln 777 778 convpn=SSUM(iim,qbyv(1,l),1) 779 convmpn=ssum(iim,masse_adv_v(1,l),1) 780 massepn=ssum(iim,masse(1,l,iq),1) 781 qpn=0. 782 do ij=1,iim 783 qpn=qpn+masse(ij,l,iq)*q(ij,l,iq) 784 enddo 785 qpn=(qpn+convpn)/(massepn+convmpn) 786 do ij=1,iip1 787 q(ij,l,iq)=qpn 788 enddo 789 790 c convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)/apols 791 c convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)/apols 792 793 convps=-SSUM(iim,qbyv(ip1jm-iim,l),1) 794 convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1) 795 masseps=ssum(iim, masse(ip1jm+1,l,iq),1) 796 qps=0. 797 do ij = ip1jm+1,ip1jmp1-1 798 qps=qps+masse(ij,l,iq)*q(ij,l,iq) 799 enddo 800 qps=(qps+convps)/(masseps+convmps) 801 do ij=ip1jm+1,ip1jmp1 802 q(ij,l,iq)=qps 803 enddo 804 805 c.-. fin ancienne version 806 807 c._. nouvelle version 808 c convpn=SSUM(iim,qbyv(1,l),1) 809 c convmpn=ssum(iim,masse_adv_v(1,l),1) 810 c oldmasse=ssum(iim,masse(1,l),1) 811 c newmasse=oldmasse+convmpn 812 c newq=(q(1,l)*oldmasse+convpn)/newmasse 813 c newmasse=newmasse/apoln 814 c DO ij = 1,iip1 815 c q(ij,l)=newq 816 c masse(ij,l,iq)=newmasse*aire(ij) 817 c ENDDO 818 c convps=-SSUM(iim,qbyv(ip1jm-iim,l),1) 819 c convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1) 820 c oldmasse=ssum(iim,masse(ip1jm-iim,l),1) 821 c newmasse=oldmasse+convmps 822 c newq=(q(ip1jmp1,l)*oldmasse+convps)/newmasse 823 c newmasse=newmasse/apols 824 c DO ij = ip1jm+1,ip1jmp1 825 c q(ij,l)=newq 826 c masse(ij,l,iq)=newmasse*aire(ij) 827 c ENDDO 828 c._. fin nouvelle version 829 ENDDO 830 831 ! retablir les fils en rapport de melange par rapport a l'air: 832 do ifils=1,tracers(iq)%nqDescen 833 iq2=tracers(iq)%iqDescen(ifils) 834 DO l=1,llm 835 DO ij=1,ip1jmp1 836 q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2) 837 enddo 838 enddo 839 enddo 840 841 !write(*,*) 'vly 853: sortie' 842 843 RETURN 844 END 845 RECURSIVE SUBROUTINE vlz(q,pente_max,masse,w,iq) 846 USE infotrac, ONLY : nqtot,tracers, ! CRisi 847 & min_qParent,min_qMass,min_ratio ! MVals et CRisi 848 c 849 c Auteurs: P.Le Van, F.Hourdin, F.Forget 850 c 851 c ******************************************************************** 852 c Shema d'advection " pseudo amont " . 853 c ******************************************************************** 854 c q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... 855 c dq sont des arguments de sortie pour le s-pg .... 856 c 857 c 858 c -------------------------------------------------------------------- 859 IMPLICIT NONE 860 c 861 include "dimensions.h" 862 include "paramet.h" 863 c 864 c 865 c Arguments: 866 c ---------- 867 REAL masse(ip1jmp1,llm,nqtot),pente_max 868 REAL q(ip1jmp1,llm,nqtot) 869 REAL w(ip1jmp1,llm+1) 870 INTEGER iq 871 c 872 c Local 873 c --------- 874 c 875 INTEGER ij,l 876 c 877 REAL wq(ip1jmp1,llm+1),newmasse 878 879 REAL dzq(ip1jmp1,llm),dzqw(ip1jmp1,llm),adzqw(ip1jmp1,llm),dzqmax 880 REAL sigw 881 882 REAL masseq(ip1jmp1,llm,nqtot),Ratio(ip1jmp1,llm,nqtot) ! CRisi 883 INTEGER ifils,iq2 ! CRisi 884 885 LOGICAL testcpu 886 SAVE testcpu 887 888 #ifdef BIDON 889 REAL temps0,temps1,second 890 SAVE temps0,temps1 891 892 DATA testcpu/.false./ 893 DATA temps0,temps1/0.,0./ 894 #endif 895 896 c On oriente tout dans le sens de la pression c'est a dire dans le 897 c sens de W 898 899 !write(*,*) 'vlz 923: entree' 900 901 #ifdef BIDON 902 IF(testcpu) THEN 903 temps0=second(0.) 904 ENDIF 905 #endif 906 DO l=2,llm 907 DO ij=1,ip1jmp1 908 dzqw(ij,l)=q(ij,l-1,iq)-q(ij,l,iq) 909 adzqw(ij,l)=abs(dzqw(ij,l)) 910 ENDDO 911 ENDDO 912 913 DO l=2,llm-1 914 DO ij=1,ip1jmp1 915 #ifdef CRAY 916 dzq(ij,l)=0.5* 917 , cvmgp(dzqw(ij,l)+dzqw(ij,l+1),0.,dzqw(ij,l)*dzqw(ij,l+1)) 918 #else 919 IF(dzqw(ij,l)*dzqw(ij,l+1).gt.0.) THEN 920 dzq(ij,l)=0.5*(dzqw(ij,l)+dzqw(ij,l+1)) 921 ELSE 922 dzq(ij,l)=0. 923 ENDIF 924 #endif 925 dzqmax=pente_max*min(adzqw(ij,l),adzqw(ij,l+1)) 926 dzq(ij,l)=sign(min(abs(dzq(ij,l)),dzqmax),dzq(ij,l)) 927 ENDDO 928 ENDDO 929 930 !write(*,*) 'vlz 954' 931 DO ij=1,ip1jmp1 932 dzq(ij,1)=0. 933 dzq(ij,llm)=0. 934 ENDDO 935 936 #ifdef BIDON 937 IF(testcpu) THEN 938 temps1=temps1+second(0.)-temps0 939 ENDIF 940 #endif 941 c --------------------------------------------------------------- 942 c .... calcul des termes d'advection verticale ....... 943 c --------------------------------------------------------------- 944 945 c calcul de - d( q * w )/ d(sigma) qu'on ajoute a dq pour calculer dq 946 947 !write(*,*) 'vlz 969' 948 DO l = 1,llm-1 949 do ij = 1,ip1jmp1 950 IF(w(ij,l+1).gt.0.) THEN 951 sigw=w(ij,l+1)/masse(ij,l+1,iq) 952 wq(ij,l+1)=w(ij,l+1)*(q(ij,l+1,iq) 953 & +0.5*(1.-sigw)*dzq(ij,l+1)) 954 ELSE 955 sigw=w(ij,l+1)/masse(ij,l,iq) 956 wq(ij,l+1)=w(ij,l+1)*(q(ij,l,iq)-0.5*(1.+sigw)*dzq(ij,l)) 957 ENDIF 958 ENDDO 959 ENDDO 960 961 DO ij=1,ip1jmp1 962 wq(ij,llm+1)=0. 963 wq(ij,1)=0. 964 ENDDO 965 966 ! CRisi: appel récursif de l'advection sur les fils. 967 ! Il faut faire ça avant d'avoir mis à jour q et masse 968 !write(*,*) 'vlsplt 942: iq,nqChildren(iq)=',iq,nqChildren(iq) 969 do ifils=1,tracers(iq)%nqDescen 970 iq2=tracers(iq)%iqDescen(ifils) 971 DO l=1,llm 972 DO ij=1,ip1jmp1 973 !masseq(ij,l,iq2)=masse(ij,l,iq)*q(ij,l,iq) 974 !Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq) 975 !MVals: veiller a ce qu'on n'ait pas de denominateur nul 976 masseq(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass) 977 if (q(ij,l,iq).gt.min_qParent) then 978 Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq) 979 else 980 Ratio(ij,l,iq2)=min_ratio 981 endif 982 enddo 983 enddo 984 enddo 985 986 do ifils=1,tracers(iq)%nqChildren 987 iq2=tracers(iq)%iqDescen(ifils) 988 call vlz(Ratio,pente_max,masseq,wq,iq2) 989 enddo 990 ! end CRisi 991 992 DO l=1,llm 993 DO ij=1,ip1jmp1 994 newmasse=masse(ij,l,iq)+w(ij,l+1)-w(ij,l) 995 q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+wq(ij,l+1)-wq(ij,l)) 996 & /newmasse 997 masse(ij,l,iq)=newmasse 998 ENDDO 999 ENDDO 1000 1001 ! retablir les fils en rapport de melange par rapport a l'air: 1002 do ifils=1,tracers(iq)%nqDescen 1003 iq2=tracers(iq)%iqDescen(ifils) 1004 DO l=1,llm 1005 DO ij=1,ip1jmp1 1006 q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2) 1007 enddo 1008 enddo 1009 enddo 1010 !write(*,*) 'vlsplt 1032' 1011 1012 RETURN 1013 END 1014 c SUBROUTINE minmaxq(zq,qmin,qmax,comment) 1015 c 1016 c#include "dimensions.h" 1017 c#include "paramet.h" 1018 1019 c CHARACTER*(*) comment 1020 c real qmin,qmax 1021 c real zq(ip1jmp1,llm) 1022 1023 c INTEGER jadrs(ip1jmp1), jbad, k, i 1024 1025 1026 c DO k = 1, llm 1027 c jbad = 0 1028 c DO i = 1, ip1jmp1 1029 c IF (zq(i,k).GT.qmax .OR. zq(i,k).LT.qmin) THEN 1030 c jbad = jbad + 1 1031 c jadrs(jbad) = i 1032 c ENDIF 1033 c ENDDO 1034 c IF (jbad.GT.0) THEN 1035 c PRINT*, comment 1036 c DO i = 1, jbad 1037 cc PRINT*, "i,k,zq=", jadrs(i),k,zq(jadrs(i),k) 1038 c ENDDO 1039 c ENDIF 1040 c ENDDO 1041 1042 c return 1043 c end 1044 subroutine minmaxq(zq,qmin,qmax,comment) 1008 enddo 1009 enddo 1010 ! !write(*,*) 'vlsplt 1032' 1011 1012 RETURN 1013 END SUBROUTINE vlz 1014 ! SUBROUTINE minmaxq(zq,qmin,qmax,comment) 1015 ! 1016 !#include "dimensions.h" 1017 !#include "paramet.h" 1018 1019 ! CHARACTER*(*) comment 1020 ! real qmin,qmax 1021 ! real zq(ip1jmp1,llm) 1022 1023 ! INTEGER jadrs(ip1jmp1), jbad, k, i 1024 1025 1026 ! DO k = 1, llm 1027 ! jbad = 0 1028 ! DO i = 1, ip1jmp1 1029 ! IF (zq(i,k).GT.qmax .OR. zq(i,k).LT.qmin) THEN 1030 ! jbad = jbad + 1 1031 ! jadrs(jbad) = i 1032 ! ENDIF 1033 ! ENDDO 1034 ! IF (jbad.GT.0) THEN 1035 ! PRINT*, comment 1036 ! DO i = 1, jbad 1037 !c PRINT*, "i,k,zq=", jadrs(i),k,zq(jadrs(i),k) 1038 ! ENDDO 1039 ! ENDIF 1040 ! ENDDO 1041 1042 ! return 1043 ! end 1044 subroutine minmaxq(zq,qmin,qmax,comment) 1045 1045 1046 1046 #include "dimensions.h" 1047 1047 #include "paramet.h" 1048 1048 1049 character*20comment1050 realqmin,qmax1051 realzq(ip1jmp1,llm)1052 realzzq(iip1,jjp1,llm)1049 character(len=20) :: comment 1050 real :: qmin,qmax 1051 real :: zq(ip1jmp1,llm) 1052 real :: zzq(iip1,jjp1,llm) 1053 1053 1054 1054 #ifdef isminmax 1055 integerimin,jmin,lmin,ijlmin1056 integerimax,jmax,lmax,ijlmax1057 1058 integerismin,ismax1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 if(zqmin.lt.qmin)1077 cs write(*,9999) comment,1078 s write(*,*) comment,1079 simin,jmin,lmin,zqmin,zzq(imin,jmin,lmin)1080 if(zqmax.gt.qmax)1081 cs write(*,9999) comment,1082 s write(*,*) comment,1083 simax,jmax,lmax,zqmax,zzq(imax,jmax,lmax)1055 integer :: imin,jmin,lmin,ijlmin 1056 integer :: imax,jmax,lmax,ijlmax 1057 1058 integer :: ismin,ismax 1059 1060 call scopy (ip1jmp1*llm,zq,1,zzq,1) 1061 1062 ijlmin=ismin(ijp1llm,zq,1) 1063 lmin=(ijlmin-1)/ip1jmp1+1 1064 ijlmin=ijlmin-(lmin-1.)*ip1jmp1 1065 jmin=(ijlmin-1)/iip1+1 1066 imin=ijlmin-(jmin-1.)*iip1 1067 zqmin=zq(ijlmin,lmin) 1068 1069 ijlmax=ismax(ijp1llm,zq,1) 1070 lmax=(ijlmax-1)/ip1jmp1+1 1071 ijlmax=ijlmax-(lmax-1.)*ip1jmp1 1072 jmax=(ijlmax-1)/iip1+1 1073 imax=ijlmax-(jmax-1.)*iip1 1074 zqmax=zq(ijlmax,lmax) 1075 1076 if(zqmin.lt.qmin) & 1077 ! s write(*,9999) comment, 1078 write(*,*) comment, & 1079 imin,jmin,lmin,zqmin,zzq(imin,jmin,lmin) 1080 if(zqmax.gt.qmax) & 1081 ! s write(*,9999) comment, 1082 write(*,*) comment, & 1083 imax,jmax,lmax,zqmax,zzq(imax,jmax,lmax) 1084 1084 1085 1085 #endif 1086 1087 c9999 format(a20,' q(',i3,',',i2,',',i2,')=',e12.5,e12.5)1088 end 1089 1090 1091 1086 return 1087 !9999 format(a20,' q(',i3,',',i2,',',i2,')=',e12.5,e12.5) 1088 end subroutine minmaxq 1089 1090 1091 -
LMDZ6/trunk/libf/dyn3dmem/vlsplt_loc.F90
r5247 r5248 2 2 ! $Id$ 3 3 ! 4 5 6 c Auteurs: P.Le Van, F.Hourdin, F.Forget 7 c 8 c********************************************************************9 cShema d'advection " pseudo amont " .10 c********************************************************************11 cnq,iq,q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg ....12 c 13 c 14 c--------------------------------------------------------------------15 16 USE infotrac, ONLY : nqtot,tracers,! CRisi &17 &min_qParent,min_qMass,min_ratio ! MVals et CRisi18 19 c 20 21 22 23 c 24 c 25 cArguments:26 c----------27 REALmasse(ijb_u:ije_u,llm,nqtot),pente_max28 REALu_m( ijb_u:ije_u,llm),pbarv( iip1,jjb_v:jje_v,llm)29 REALq(ijb_u:ije_u,llm,nqtot) ! CRisi: ajout dimension nqtot30 REAL w(ijb_u:ije_u,llm)31 INTEGERiq ! CRisi32 c 33 c Local 34 c---------35 c 36 INTEGERij,l,j,i,iju,ijq,indu(ijnb_u),niju37 INTEGERn0,iadvplus(ijb_u:ije_u,llm),nl(llm)38 c 39 REALnew_m,zu_m,zdum(ijb_u:ije_u,llm)40 REALsigu(ijb_u:ije_u),dxq(ijb_u:ije_u,llm),dxqu(ijb_u:ije_u)41 REALzz(ijb_u:ije_u)42 REALadxqu(ijb_u:ije_u),dxqmax(ijb_u:ije_u,llm)43 REALu_mq(ijb_u:ije_u,llm)44 45 REALRatio(ijb_u:ije_u,llm,nqtot) ! CRisi46 INTEGERifils,iq2 ! CRisi47 48 Logicalextremum49 50 REALSSUM51 52 53 REALz1,z2,z354 55 INTEGERijb,ije,ijb_x,ije_x56 57 58 !& iq,ijb_x59 ccalcul de la pente a droite et a gauche de la maille60 61 62 63 64 65 66 67 68 cIF (pente_max.gt.10) THEN69 70 ccalcul des pentes avec limitation, Van Leer scheme I:71 c-----------------------------------------------------72 73 ccalcul de la pente aux points u74 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 75 76 77 78 79 cIF(u_m(ij,l).lt.0.) stop'limx n admet pas les U<0'80 csigu(ij)=u_m(ij,l)/masse(ij,l,iq)81 82 83 84 csigu(ij)=sigu(ij-iim)85 86 87 88 89 90 91 ccalcul de la pente maximum dans la maille en valeur absolue92 93 94 dxqmax(ij,l)=pente_max*95 ,min(adxqu(ij-1),adxqu(ij))96 climitation subtile97 c, min(adxqu(ij-1)/sigu(ij-1),adxqu(ij)/(1.-sigu(ij)))98 99 100 101 102 103 104 105 106 4 RECURSIVE SUBROUTINE vlx_loc(q,pente_max,masse,u_m,ijb_x,ije_x,iq) 5 6 ! Auteurs: P.Le Van, F.Hourdin, F.Forget 7 ! 8 ! ******************************************************************** 9 ! Shema d'advection " pseudo amont " . 10 ! ******************************************************************** 11 ! nq,iq,q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... 12 ! 13 ! 14 ! -------------------------------------------------------------------- 15 USE parallel_lmdz 16 USE infotrac, ONLY : nqtot,tracers, & ! CRisi & 17 min_qParent,min_qMass,min_ratio ! MVals et CRisi 18 IMPLICIT NONE 19 ! 20 include "dimensions.h" 21 include "paramet.h" 22 include "iniprint.h" 23 ! 24 ! 25 ! Arguments: 26 ! ---------- 27 REAL :: masse(ijb_u:ije_u,llm,nqtot),pente_max 28 REAL :: u_m( ijb_u:ije_u,llm),pbarv( iip1,jjb_v:jje_v,llm) 29 REAL :: q(ijb_u:ije_u,llm,nqtot) ! CRisi: ajout dimension nqtot 30 REAL :: w(ijb_u:ije_u,llm) 31 INTEGER :: iq ! CRisi 32 ! 33 ! Local 34 ! --------- 35 ! 36 INTEGER :: ij,l,j,i,iju,ijq,indu(ijnb_u),niju 37 INTEGER :: n0,iadvplus(ijb_u:ije_u,llm),nl(llm) 38 ! 39 REAL :: new_m,zu_m,zdum(ijb_u:ije_u,llm) 40 REAL :: sigu(ijb_u:ije_u),dxq(ijb_u:ije_u,llm),dxqu(ijb_u:ije_u) 41 REAL :: zz(ijb_u:ije_u) 42 REAL :: adxqu(ijb_u:ije_u),dxqmax(ijb_u:ije_u,llm) 43 REAL :: u_mq(ijb_u:ije_u,llm) 44 45 REAL :: Ratio(ijb_u:ije_u,llm,nqtot) ! CRisi 46 INTEGER :: ifils,iq2 ! CRisi 47 48 Logical :: extremum 49 50 REAL :: SSUM 51 EXTERNAL SSUM 52 53 REAL :: z1,z2,z3 54 55 INTEGER :: ijb,ije,ijb_x,ije_x 56 57 ! !write(*,*) 'vlsplt 58: entree dans vlx_loc, iq,ijb_x=', 58 ! & iq,ijb_x 59 ! calcul de la pente a droite et a gauche de la maille 60 61 ijb=ijb_x 62 ije=ije_x 63 64 if (pole_nord.and.ijb==1) ijb=ijb+iip1 65 if (pole_sud.and.ije==ip1jmp1) ije=ije-iip1 66 67 IF (pente_max.gt.-1.e-5) THEN 68 ! IF (pente_max.gt.10) THEN 69 70 ! calcul des pentes avec limitation, Van Leer scheme I: 71 ! ----------------------------------------------------- 72 ! ! on a besoin de q entre ijb et ije 73 ! calcul de la pente aux points u 74 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 75 DO l = 1, llm 76 77 DO ij=ijb,ije-1 78 dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq) 79 ! IF(u_m(ij,l).lt.0.) stop'limx n admet pas les U<0' 80 ! sigu(ij)=u_m(ij,l)/masse(ij,l,iq) 81 ENDDO 82 DO ij=ijb+iip1-1,ije,iip1 83 dxqu(ij)=dxqu(ij-iim) 84 ! sigu(ij)=sigu(ij-iim) 85 ENDDO 86 87 DO ij=ijb,ije 88 adxqu(ij)=abs(dxqu(ij)) 89 ENDDO 90 91 ! calcul de la pente maximum dans la maille en valeur absolue 92 93 DO ij=ijb+1,ije 94 dxqmax(ij,l)=pente_max* & 95 min(adxqu(ij-1),adxqu(ij)) 96 ! limitation subtile 97 ! , min(adxqu(ij-1)/sigu(ij-1),adxqu(ij)/(1.-sigu(ij))) 98 99 100 ENDDO 101 102 DO ij=ijb+iip1-1,ije,iip1 103 dxqmax(ij-iim,l)=dxqmax(ij,l) 104 ENDDO 105 106 DO ij=ijb+1,ije 107 107 #ifdef CRAY 108 dxq(ij,l)=109 ,cvmgp(dxqu(ij-1)+dxqu(ij),0.,dxqu(ij-1)*dxqu(ij))108 dxq(ij,l)= & 109 cvmgp(dxqu(ij-1)+dxqu(ij),0.,dxqu(ij-1)*dxqu(ij)) 110 110 #else 111 112 113 114 cextremum local115 116 111 IF(dxqu(ij-1)*dxqu(ij).gt.0) THEN 112 dxq(ij,l)=dxqu(ij-1)+dxqu(ij) 113 ELSE 114 ! extremum local 115 dxq(ij,l)=0. 116 ENDIF 117 117 #endif 118 119 dxq(ij,l)=120 ,sign(min(abs(dxq(ij,l)),dxqmax(ij,l)),dxq(ij,l))121 122 123 124 c$OMP END DO NOWAIT125 cprint*,'Ok calcul des pentes'126 127 128 129 cPentes produits:130 c----------------131 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 cextremum local147 148 149 150 151 152 c$OMP END DO NOWAIT153 154 155 156 157 cbouclage de la pente en iip1:158 c-----------------------------159 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)160 161 162 163 164 165 166 167 168 169 c$OMP END DO NOWAIT170 cprint*,'Bouclage en iip1'171 172 ccalcul des flux a gauche et a droite118 dxq(ij,l)=0.5*dxq(ij,l) 119 dxq(ij,l)= & 120 sign(min(abs(dxq(ij,l)),dxqmax(ij,l)),dxq(ij,l)) 121 ENDDO 122 123 ENDDO ! l=1,llm 124 !$OMP END DO NOWAIT 125 ! print*,'Ok calcul des pentes' 126 127 ELSE ! (pente_max.lt.-1.e-5) 128 129 ! Pentes produits: 130 ! ---------------- 131 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 132 DO l = 1, llm 133 DO ij=ijb,ije-1 134 dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq) 135 ENDDO 136 DO ij=ijb+iip1-1,ije,iip1 137 dxqu(ij)=dxqu(ij-iim) 138 ENDDO 139 140 DO ij=ijb+1,ije 141 zz(ij)=dxqu(ij-1)*dxqu(ij) 142 zz(ij)=zz(ij)+zz(ij) 143 IF(zz(ij).gt.0) THEN 144 dxq(ij,l)=zz(ij)/(dxqu(ij-1)+dxqu(ij)) 145 ELSE 146 ! extremum local 147 dxq(ij,l)=0. 148 ENDIF 149 ENDDO 150 151 ENDDO 152 !$OMP END DO NOWAIT 153 ENDIF ! (pente_max.lt.-1.e-5) 154 155 ! !write(*,*) 'vlx 156: iq,ijb_x=',iq,ijb_x 156 157 ! bouclage de la pente en iip1: 158 ! ----------------------------- 159 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 160 DO l=1,llm 161 DO ij=ijb+iip1-1,ije,iip1 162 dxq(ij-iim,l)=dxq(ij,l) 163 ENDDO 164 DO ij=ijb,ije 165 iadvplus(ij,l)=0 166 ENDDO 167 168 ENDDO 169 !$OMP END DO NOWAIT 170 ! print*,'Bouclage en iip1' 171 172 ! calcul des flux a gauche et a droite 173 173 174 174 #ifdef CRAY 175 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)176 177 178 zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l,iq),179 , 1.+u_m(ij,l)/masse(ij+1,l,iq),180 ,u_m(ij,l,iq))181 182 u_mq(ij,l)=cvmgp(183 , q(ij,l,iq)+zdum(ij,l)*dxq(ij,l),184 , q(ij+1,l,iq)-zdum(ij,l)*dxq(ij+1,l),185 ,u_m(ij,l))186 187 188 189 c$OMP END DO NOWAIT175 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 176 DO l=1,llm 177 DO ij=ijb,ije-1 178 zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l,iq), & 179 1.+u_m(ij,l)/masse(ij+1,l,iq), & 180 u_m(ij,l,iq)) 181 zdum(ij,l)=0.5*zdum(ij,l) 182 u_mq(ij,l)=cvmgp( & 183 q(ij,l,iq)+zdum(ij,l)*dxq(ij,l), & 184 q(ij+1,l,iq)-zdum(ij,l)*dxq(ij+1,l), & 185 u_m(ij,l)) 186 u_mq(ij,l)=u_m(ij,l)*u_mq(ij,l) 187 ENDDO 188 ENDDO 189 !$OMP END DO NOWAIT 190 190 #else 191 con cumule le flux correspondant a toutes les mailles dont la masse192 cau travers de la paroi pENDant le pas de temps.193 cprint*,'Cumule ....'194 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)195 196 197 198 cprint*,'masse(',ij,')=',masse(ij,l,iq)199 200 201 u_mq(ij,l)=u_m(ij,l)*(q(ij,l,iq)202 :+0.5*zdum(ij,l)*dxq(ij,l))203 204 205 u_mq(ij,l)=u_m(ij,l)*(q(ij+1,l,iq)206 :-0.5*zdum(ij,l)*dxq(ij+1,l))207 208 209 210 c$OMP END DO NOWAIT191 ! on cumule le flux correspondant a toutes les mailles dont la masse 192 ! au travers de la paroi pENDant le pas de temps. 193 ! print*,'Cumule ....' 194 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 195 ! ! on a besoin de masse entre ijb et ije 196 DO l=1,llm 197 DO ij=ijb,ije-1 198 ! print*,'masse(',ij,')=',masse(ij,l,iq) 199 IF (u_m(ij,l).gt.0.) THEN 200 zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l,iq) 201 u_mq(ij,l)=u_m(ij,l)*(q(ij,l,iq) & 202 +0.5*zdum(ij,l)*dxq(ij,l)) 203 ELSE 204 zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l,iq) 205 u_mq(ij,l)=u_m(ij,l)*(q(ij+1,l,iq) & 206 -0.5*zdum(ij,l)*dxq(ij+1,l)) 207 ENDIF 208 ENDDO 209 ENDDO 210 !$OMP END DO NOWAIT 211 211 #endif 212 212 213 c go to 9999 214 c detection des points ou on advecte plus que la masse de la 215 c maille 216 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 217 DO l=1,llm 218 DO ij=ijb,ije-1 219 IF(zdum(ij,l).lt.0) THEN 220 iadvplus(ij,l)=1 221 u_mq(ij,l)=0. 222 ENDIF 223 ENDDO 224 ENDDO 225 c$OMP END DO NOWAIT 226 c print*,'Ok test 1' 227 228 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 229 DO l=1,llm 230 DO ij=ijb+iip1-1,ije,iip1 231 iadvplus(ij,l)=iadvplus(ij-iim,l) 232 ENDDO 233 ENDDO 234 c$OMP END DO NOWAIT 235 c print*,'Ok test 2' 236 237 238 c traitement special pour le cas ou on advecte en longitude plus que le 239 c contenu de la maille. 240 c cette partie est mal vectorisee. 241 242 c calcul du nombre de maille sur lequel on advecte plus que la maille. 243 244 n0=0 245 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 246 DO l=1,llm 247 nl(l)=0 248 DO ij=ijb,ije 249 nl(l)=nl(l)+iadvplus(ij,l) 250 ENDDO 251 n0=n0+nl(l) 252 ENDDO 253 c$OMP END DO NOWAIT 254 cym IF(n0.gt.1) THEN 255 cym IF(n0.gt.0) THEN 256 257 c PRINT*,'Nombre de points pour lesquels on advect plus que le' 258 c & ,'contenu de la maille : ',n0 259 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 260 261 262 DO l=1,llm 263 IF(nl(l).gt.0) THEN 264 iju=0 265 c indicage des mailles concernees par le traitement special 266 DO ij=ijb,ije 267 IF(iadvplus(ij,l).eq.1.and.mod(ij,iip1).ne.0) THEN 268 iju=iju+1 269 indu(iju)=ij 270 ENDIF 271 ENDDO 272 niju=iju 273 !PRINT*,'vlx 278, niju,nl',niju,nl(l) 274 275 c traitement des mailles 276 DO iju=1,niju 277 ij=indu(iju) 278 j=(ij-1)/iip1+1 279 zu_m=u_m(ij,l) 280 u_mq(ij,l)=0. 281 IF(zu_m.gt.0.) THEN 282 ijq=ij 283 i=ijq-(j-1)*iip1 284 c accumulation pour les mailles completements advectees 285 do while(zu_m.gt.masse(ijq,l,iq)) 286 u_mq(ij,l)=u_mq(ij,l) 287 & +q(ijq,l,iq)*masse(ijq,l,iq) 288 zu_m=zu_m-masse(ijq,l,iq) 289 i=mod(i-2+iim,iim)+1 290 ijq=(j-1)*iip1+i 291 ENDDO 292 c ajout de la maille non completement advectee 293 u_mq(ij,l)=u_mq(ij,l)+zu_m* 294 & (q(ijq,l,iq)+0.5* 295 & (1.-zu_m/masse(ijq,l,iq))*dxq(ijq,l)) 296 ELSE 297 ijq=ij+1 298 i=ijq-(j-1)*iip1 299 c accumulation pour les mailles completements advectees 300 do while(-zu_m.gt.masse(ijq,l,iq)) 301 u_mq(ij,l)=u_mq(ij,l)-q(ijq,l,iq) 302 & *masse(ijq,l,iq) 303 zu_m=zu_m+masse(ijq,l,iq) 304 i=mod(i,iim)+1 305 ijq=(j-1)*iip1+i 306 ENDDO 307 c ajout de la maille non completement advectee 308 u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l,iq)- 309 & 0.5*(1.+zu_m/masse(ijq,l,iq))*dxq(ijq,l)) 310 ENDIF 311 ENDDO 312 ENDIF 313 ENDDO 314 c$OMP END DO NOWAIT 315 cym ENDIF ! n0.gt.0 316 9999 continue 317 318 c bouclage en latitude 319 c print*,'Avant bouclage en latitude' 320 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 321 DO l=1,llm 322 DO ij=ijb+iip1-1,ije,iip1 323 u_mq(ij,l)=u_mq(ij-iim,l) 324 ENDDO 325 ENDDO 326 c$OMP END DO NOWAIT 327 328 ! CRisi: appel récursif de l'advection sur les fils. 329 ! Il faut faire ça avant d'avoir mis à jour q et masse 330 331 do ifils=1,tracers(iq)%nqDescen 332 ! attention: comme Ratio est utilisé comme q dans l'appel 333 ! recursif, il doit contenir à lui seul tous les indices de tous 334 ! les descendants! 335 iq2=tracers(iq)%iqDescen(ifils) 336 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 337 DO l=1,llm 338 DO ij=ijb,ije 339 ! On a besoin de q et masse seulement entre ijb et ije. On ne 340 ! les calcule donc que de ijb à ije 341 !MVals: veiller a ce qu'on n'ait pas de denominateur nul 342 masse(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass) 343 if (q(ij,l,iq).gt.min_qParent) then ! modif 13 nov 2020 344 Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq) 345 else 346 Ratio(ij,l,iq2)=min_ratio 347 endif 348 enddo 349 enddo 350 c$OMP END DO NOWAIT 351 enddo !do ifils=1,tracers(iq)%nqDescen 352 do ifils=1,tracers(iq)%nqChildren 353 iq2=tracers(iq)%iqDescen(ifils) 354 call vlx_loc(Ratio,pente_max,masse,u_mq,ijb_x,ije_x,iq2) 213 ! go to 9999 214 ! detection des points ou on advecte plus que la masse de la 215 ! maille 216 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 217 DO l=1,llm 218 DO ij=ijb,ije-1 219 IF(zdum(ij,l).lt.0) THEN 220 iadvplus(ij,l)=1 221 u_mq(ij,l)=0. 222 ENDIF 223 ENDDO 224 ENDDO 225 !$OMP END DO NOWAIT 226 ! print*,'Ok test 1' 227 228 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 229 DO l=1,llm 230 DO ij=ijb+iip1-1,ije,iip1 231 iadvplus(ij,l)=iadvplus(ij-iim,l) 232 ENDDO 233 ENDDO 234 !$OMP END DO NOWAIT 235 ! print*,'Ok test 2' 236 237 238 ! traitement special pour le cas ou on advecte en longitude plus que le 239 ! contenu de la maille. 240 ! cette partie est mal vectorisee. 241 242 ! calcul du nombre de maille sur lequel on advecte plus que la maille. 243 244 n0=0 245 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 246 DO l=1,llm 247 nl(l)=0 248 DO ij=ijb,ije 249 nl(l)=nl(l)+iadvplus(ij,l) 250 ENDDO 251 n0=n0+nl(l) 252 ENDDO 253 !$OMP END DO NOWAIT 254 !ym IF(n0.gt.1) THEN 255 !ym IF(n0.gt.0) THEN 256 257 ! PRINT*,'Nombre de points pour lesquels on advect plus que le' 258 ! & ,'contenu de la maille : ',n0 259 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 260 261 262 DO l=1,llm 263 IF(nl(l).gt.0) THEN 264 iju=0 265 ! indicage des mailles concernees par le traitement special 266 DO ij=ijb,ije 267 IF(iadvplus(ij,l).eq.1.and.mod(ij,iip1).ne.0) THEN 268 iju=iju+1 269 indu(iju)=ij 270 ENDIF 271 ENDDO 272 niju=iju 273 ! !PRINT*,'vlx 278, niju,nl',niju,nl(l) 274 275 ! traitement des mailles 276 DO iju=1,niju 277 ij=indu(iju) 278 j=(ij-1)/iip1+1 279 zu_m=u_m(ij,l) 280 u_mq(ij,l)=0. 281 IF(zu_m.gt.0.) THEN 282 ijq=ij 283 i=ijq-(j-1)*iip1 284 ! accumulation pour les mailles completements advectees 285 do while(zu_m.gt.masse(ijq,l,iq)) 286 u_mq(ij,l)=u_mq(ij,l) & 287 +q(ijq,l,iq)*masse(ijq,l,iq) 288 zu_m=zu_m-masse(ijq,l,iq) 289 i=mod(i-2+iim,iim)+1 290 ijq=(j-1)*iip1+i 291 ENDDO 292 ! ajout de la maille non completement advectee 293 u_mq(ij,l)=u_mq(ij,l)+zu_m* & 294 (q(ijq,l,iq)+0.5* & 295 (1.-zu_m/masse(ijq,l,iq))*dxq(ijq,l)) 296 ELSE 297 ijq=ij+1 298 i=ijq-(j-1)*iip1 299 ! accumulation pour les mailles completements advectees 300 do while(-zu_m.gt.masse(ijq,l,iq)) 301 u_mq(ij,l)=u_mq(ij,l)-q(ijq,l,iq) & 302 *masse(ijq,l,iq) 303 zu_m=zu_m+masse(ijq,l,iq) 304 i=mod(i,iim)+1 305 ijq=(j-1)*iip1+i 306 ENDDO 307 ! ajout de la maille non completement advectee 308 u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l,iq)- & 309 0.5*(1.+zu_m/masse(ijq,l,iq))*dxq(ijq,l)) 310 ENDIF 311 ENDDO 312 ENDIF 313 ENDDO 314 !$OMP END DO NOWAIT 315 !ym ENDIF ! n0.gt.0 316 9999 continue 317 318 ! bouclage en latitude 319 ! print*,'Avant bouclage en latitude' 320 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 321 DO l=1,llm 322 DO ij=ijb+iip1-1,ije,iip1 323 u_mq(ij,l)=u_mq(ij-iim,l) 324 ENDDO 325 ENDDO 326 !$OMP END DO NOWAIT 327 328 ! CRisi: appel récursif de l'advection sur les fils. 329 ! Il faut faire ça avant d'avoir mis à jour q et masse 330 331 do ifils=1,tracers(iq)%nqDescen 332 ! ! attention: comme Ratio est utilisé comme q dans l'appel 333 ! ! recursif, il doit contenir à lui seul tous les indices de tous 334 ! ! les descendants! 335 iq2=tracers(iq)%iqDescen(ifils) 336 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 337 DO l=1,llm 338 DO ij=ijb,ije 339 ! ! On a besoin de q et masse seulement entre ijb et ije. On ne 340 ! ! les calcule donc que de ijb à ije 341 ! !MVals: veiller a ce qu'on n'ait pas de denominateur nul 342 masse(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass) 343 if (q(ij,l,iq).gt.min_qParent) then ! modif 13 nov 2020 344 Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq) 345 else 346 Ratio(ij,l,iq2)=min_ratio 347 endif 355 348 enddo 356 ! end CRisi 357 358 359 c calcul des tENDances 360 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 361 DO l=1,llm 362 DO ij=ijb+1,ije 363 !MVals: veiller a ce qu'on n'ait pas de denominateur nul 364 new_m=max(masse(ij,l,iq)+u_m(ij-1,l)-u_m(ij,l),min_qMass) 365 q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+ 366 & u_mq(ij-1,l)-u_mq(ij,l)) 367 & /new_m 368 masse(ij,l,iq)=new_m 369 ENDDO 370 c ModIF Fred 22 03 96 correction d'un bug (les scopy ci-dessous) 371 DO ij=ijb+iip1-1,ije,iip1 372 q(ij-iim,l,iq)=q(ij,l,iq) 373 masse(ij-iim,l,iq)=masse(ij,l,iq) 374 ENDDO 375 ENDDO 376 c$OMP END DO NOWAIT 377 378 ! retablir les fils en rapport de melange par rapport a l'air: 379 ! On calcule q entre ijb+1 et ije -> on fait pareil pour ratio 380 ! puis on boucle en longitude 381 do ifils=1,tracers(iq)%nqDescen 382 iq2=tracers(iq)%iqDescen(ifils) 383 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 384 DO l=1,llm 385 DO ij=ijb+1,ije 386 q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2) 387 enddo 388 DO ij=ijb+iip1-1,ije,iip1 389 q(ij-iim,l,iq2)=q(ij,l,iq2) 390 enddo 391 enddo 392 c$OMP END DO NOWAIT 349 enddo 350 !$OMP END DO NOWAIT 351 enddo !do ifils=1,tracers(iq)%nqDescen 352 do ifils=1,tracers(iq)%nqChildren 353 iq2=tracers(iq)%iqDescen(ifils) 354 call vlx_loc(Ratio,pente_max,masse,u_mq,ijb_x,ije_x,iq2) 355 enddo 356 ! end CRisi 357 358 359 ! calcul des tENDances 360 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 361 DO l=1,llm 362 DO ij=ijb+1,ije 363 ! !MVals: veiller a ce qu'on n'ait pas de denominateur nul 364 new_m=max(masse(ij,l,iq)+u_m(ij-1,l)-u_m(ij,l),min_qMass) 365 q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+ & 366 u_mq(ij-1,l)-u_mq(ij,l)) & 367 /new_m 368 masse(ij,l,iq)=new_m 369 ENDDO 370 ! ModIF Fred 22 03 96 correction d'un bug (les scopy ci-dessous) 371 DO ij=ijb+iip1-1,ije,iip1 372 q(ij-iim,l,iq)=q(ij,l,iq) 373 masse(ij-iim,l,iq)=masse(ij,l,iq) 374 ENDDO 375 ENDDO 376 !$OMP END DO NOWAIT 377 378 ! retablir les fils en rapport de melange par rapport a l'air: 379 ! ! On calcule q entre ijb+1 et ije -> on fait pareil pour ratio 380 ! ! puis on boucle en longitude 381 do ifils=1,tracers(iq)%nqDescen 382 iq2=tracers(iq)%iqDescen(ifils) 383 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 384 DO l=1,llm 385 DO ij=ijb+1,ije 386 q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2) 393 387 enddo 394 395 !write(*,*) 'vlsplt 399: iq,ijb_x=',iq,ijb_x 396 c CALL SCOPY((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1) 397 c CALL SCOPY((jjm-1)*llm,masse(iip1+iip1,1),iip1,masse(iip2,1),iip1) 398 399 400 RETURN 401 END 402 403 404 RECURSIVE SUBROUTINE vly_loc(q,pente_max,masse,masse_adv_v,iq) 405 c 406 c Auteurs: P.Le Van, F.Hourdin, F.Forget 407 c 408 c ******************************************************************** 409 c Shema d'advection " pseudo amont " . 410 c ******************************************************************** 411 c q,masse_adv_v,w sont des arguments d'entree pour le s-pg .... 412 c dq sont des arguments de sortie pour le s-pg .... 413 c 414 c 415 c -------------------------------------------------------------------- 416 USE parallel_lmdz 417 USE infotrac, ONLY : nqtot,tracers, ! CRisi & 418 & min_qParent,min_qMass,min_ratio ! MVals et CRisi 419 USE comconst_mod, ONLY: pi 420 IMPLICIT NONE 421 c 422 include "dimensions.h" 423 include "paramet.h" 424 include "comgeom.h" 425 c 426 c 427 c Arguments: 428 c ---------- 429 REAL masse(ijb_u:ije_u,llm,nqtot),pente_max 430 REAL masse_adv_v( ijb_v:ije_v,llm) 431 REAL q(ijb_u:ije_u,llm,nqtot), dq( ijb_u:ije_u,llm) 432 INTEGER iq ! CRisi 433 c 434 c Local 435 c --------- 436 c 437 INTEGER i,ij,l 438 c 439 REAL airej2,airejjm,airescb(iim),airesch(iim) 440 REAL dyq(ijb_u:ije_u,llm),dyqv(ijb_v:ije_v),zdvm(ijb_u:ije_u,llm) 441 REAL adyqv(ijb_v:ije_v),dyqmax(ijb_u:ije_u) 442 REAL qbyv(ijb_v:ije_v,llm) 443 444 REAL qpns,qpsn,appn,apps,dyn1,dys1,dyn2,dys2,newmasse,fn,fs 445 c REAL newq,oldmasse 446 Logical extremum,first,testcpu 447 REAL temps0,temps1,temps2,temps3,temps4,temps5,second 448 SAVE temps0,temps1,temps2,temps3,temps4,temps5 449 c$OMP THREADPRIVATE(temps0,temps1,temps2,temps3,temps4,temps5) 450 SAVE first,testcpu 451 c$OMP THREADPRIVATE(first,testcpu) 452 453 REAL convpn,convps,convmpn,convmps 454 real massepn,masseps,qpn,qps 455 REAL sinlon(iip1),sinlondlon(iip1) 456 REAL coslon(iip1),coslondlon(iip1) 457 SAVE sinlon,coslon,sinlondlon,coslondlon 458 c$OMP THREADPRIVATE(sinlon,coslon,sinlondlon,coslondlon) 459 SAVE airej2,airejjm 460 c$OMP THREADPRIVATE(airej2,airejjm) 461 462 REAL Ratio(ijb_u:ije_u,llm,nqtot) ! CRisi 463 INTEGER ifils,iq2 ! CRisi 464 c 465 c 466 REAL SSUM 467 EXTERNAL SSUM 468 469 DATA first,testcpu/.true.,.false./ 470 DATA temps0,temps1,temps2,temps3,temps4,temps5/0.,0.,0.,0.,0.,0./ 471 INTEGER ijb,ije 472 INTEGER ijbm,ijem 473 474 ijb=ij_begin-2*iip1 475 ije=ij_end+2*iip1 476 if (pole_nord) ijb=ij_begin 477 if (pole_sud) ije=ij_end 478 479 IF(first) THEN 480 PRINT*,'Shema Amont nouveau appele dans Vanleer ' 481 first=.false. 482 do i=2,iip1 483 coslon(i)=cos(rlonv(i)) 484 sinlon(i)=sin(rlonv(i)) 485 coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi 486 sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi 487 ENDDO 488 coslon(1)=coslon(iip1) 489 coslondlon(1)=coslondlon(iip1) 490 sinlon(1)=sinlon(iip1) 491 sinlondlon(1)=sinlondlon(iip1) 492 airej2 = SSUM( iim, aire(iip2), 1 ) 493 airejjm= SSUM( iim, aire(ip1jm -iim), 1 ) 388 DO ij=ijb+iip1-1,ije,iip1 389 q(ij-iim,l,iq2)=q(ij,l,iq2) 390 enddo 391 enddo 392 !$OMP END DO NOWAIT 393 enddo 394 395 ! !write(*,*) 'vlsplt 399: iq,ijb_x=',iq,ijb_x 396 ! CALL SCOPY((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1) 397 ! CALL SCOPY((jjm-1)*llm,masse(iip1+iip1,1),iip1,masse(iip2,1),iip1) 398 399 400 RETURN 401 END SUBROUTINE vlx_loc 402 403 404 RECURSIVE SUBROUTINE vly_loc(q,pente_max,masse,masse_adv_v,iq) 405 ! 406 ! Auteurs: P.Le Van, F.Hourdin, F.Forget 407 ! 408 ! ******************************************************************** 409 ! Shema d'advection " pseudo amont " . 410 ! ******************************************************************** 411 ! q,masse_adv_v,w sont des arguments d'entree pour le s-pg .... 412 ! dq sont des arguments de sortie pour le s-pg .... 413 ! 414 ! 415 ! -------------------------------------------------------------------- 416 USE parallel_lmdz 417 USE infotrac, ONLY : nqtot,tracers, & ! CRisi & 418 min_qParent,min_qMass,min_ratio ! MVals et CRisi 419 USE comconst_mod, ONLY: pi 420 IMPLICIT NONE 421 ! 422 include "dimensions.h" 423 include "paramet.h" 424 include "comgeom.h" 425 ! 426 ! 427 ! Arguments: 428 ! ---------- 429 REAL :: masse(ijb_u:ije_u,llm,nqtot),pente_max 430 REAL :: masse_adv_v( ijb_v:ije_v,llm) 431 REAL :: q(ijb_u:ije_u,llm,nqtot), dq( ijb_u:ije_u,llm) 432 INTEGER :: iq ! CRisi 433 ! 434 ! Local 435 ! --------- 436 ! 437 INTEGER :: i,ij,l 438 ! 439 REAL :: airej2,airejjm,airescb(iim),airesch(iim) 440 REAL :: dyq(ijb_u:ije_u,llm),dyqv(ijb_v:ije_v),zdvm(ijb_u:ije_u,llm) 441 REAL :: adyqv(ijb_v:ije_v),dyqmax(ijb_u:ije_u) 442 REAL :: qbyv(ijb_v:ije_v,llm) 443 444 REAL :: qpns,qpsn,appn,apps,dyn1,dys1,dyn2,dys2,newmasse,fn,fs 445 ! REAL newq,oldmasse 446 Logical :: extremum,first,testcpu 447 REAL :: temps0,temps1,temps2,temps3,temps4,temps5,second 448 SAVE temps0,temps1,temps2,temps3,temps4,temps5 449 !$OMP THREADPRIVATE(temps0,temps1,temps2,temps3,temps4,temps5) 450 SAVE first,testcpu 451 !$OMP THREADPRIVATE(first,testcpu) 452 453 REAL :: convpn,convps,convmpn,convmps 454 real :: massepn,masseps,qpn,qps 455 REAL :: sinlon(iip1),sinlondlon(iip1) 456 REAL :: coslon(iip1),coslondlon(iip1) 457 SAVE sinlon,coslon,sinlondlon,coslondlon 458 !$OMP THREADPRIVATE(sinlon,coslon,sinlondlon,coslondlon) 459 SAVE airej2,airejjm 460 !$OMP THREADPRIVATE(airej2,airejjm) 461 462 REAL :: Ratio(ijb_u:ije_u,llm,nqtot) ! CRisi 463 INTEGER :: ifils,iq2 ! CRisi 464 ! 465 ! 466 REAL :: SSUM 467 EXTERNAL SSUM 468 469 DATA first,testcpu/.true.,.false./ 470 DATA temps0,temps1,temps2,temps3,temps4,temps5/0.,0.,0.,0.,0.,0./ 471 INTEGER :: ijb,ije 472 INTEGER :: ijbm,ijem 473 474 ijb=ij_begin-2*iip1 475 ije=ij_end+2*iip1 476 if (pole_nord) ijb=ij_begin 477 if (pole_sud) ije=ij_end 478 479 IF(first) THEN 480 PRINT*,'Shema Amont nouveau appele dans Vanleer ' 481 first=.false. 482 do i=2,iip1 483 coslon(i)=cos(rlonv(i)) 484 sinlon(i)=sin(rlonv(i)) 485 coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi 486 sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi 487 ENDDO 488 coslon(1)=coslon(iip1) 489 coslondlon(1)=coslondlon(iip1) 490 sinlon(1)=sinlon(iip1) 491 sinlondlon(1)=sinlondlon(iip1) 492 airej2 = SSUM( iim, aire(iip2), 1 ) 493 airejjm= SSUM( iim, aire(ip1jm -iim), 1 ) 494 ENDIF 495 496 ! 497 ! PRINT*,'CALCUL EN LATITUDE' 498 499 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 500 DO l = 1, llm 501 ! 502 ! -------------------------------- 503 ! CALCUL EN LATITUDE 504 ! -------------------------------- 505 506 ! On commence par calculer la valeur du traceur moyenne sur le premier cercle 507 ! de latitude autour du pole (qpns pour le pole nord et qpsn pour 508 ! le pole nord) qui sera utilisee pour evaluer les pentes au pole. 509 510 if (pole_nord) then 511 DO i = 1, iim 512 airescb(i) = aire(i+ iip1) * q(i+ iip1,l,iq) 513 ENDDO 514 qpns = SSUM( iim, airescb ,1 ) / airej2 515 endif 516 517 if (pole_sud) then 518 DO i = 1, iim 519 airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l,iq) 520 ENDDO 521 qpsn = SSUM( iim, airesch ,1 ) / airejjm 522 endif 523 524 ! calcul des pentes aux points v 525 526 ijb=ij_begin-2*iip1 527 ije=ij_end+iip1 528 if (pole_nord) ijb=ij_begin 529 if (pole_sud) ije=ij_end-iip1 530 531 ! ! on a besoin de q entre ij_begin-2*iip1 et ij_end+2*iip1 532 ! ! Si pole sud, entre ij_begin-2*iip1 et ij_end 533 ! ! Si pole Nord, entre ij_begin et ij_end+2*iip1 534 DO ij=ijb,ije 535 dyqv(ij)=q(ij,l,iq)-q(ij+iip1,l,iq) 536 adyqv(ij)=abs(dyqv(ij)) 537 ENDDO 538 539 540 ! calcul des pentes aux points scalaires 541 ijb=ij_begin-iip1 542 ije=ij_end+iip1 543 if (pole_nord) ijb=ij_begin+iip1 544 if (pole_sud) ije=ij_end-iip1 545 546 DO ij=ijb,ije 547 dyq(ij,l)=.5*(dyqv(ij-iip1)+dyqv(ij)) 548 dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij)) 549 dyqmax(ij)=pente_max*dyqmax(ij) 550 ENDDO 551 552 ! calcul des pentes aux poles 553 IF (pole_nord) THEN 554 DO ij=1,iip1 555 dyq(ij,l)=qpns-q(ij+iip1,l,iq) 556 ENDDO 557 558 dyn1=0. 559 dyn2=0. 560 DO ij=1,iim 561 dyn1=dyn1+sinlondlon(ij)*dyq(ij,l) 562 dyn2=dyn2+coslondlon(ij)*dyq(ij,l) 563 ENDDO 564 DO ij=1,iip1 565 dyq(ij,l)=dyn1*sinlon(ij)+dyn2*coslon(ij) 566 ENDDO 567 568 DO ij=1,iip1 569 dyq(ij,l)=0. 570 ENDDO 571 ! ym tout cela ne sert pas a grand chose 572 ENDIF 573 574 IF (pole_sud) THEN 575 576 DO ij=1,iip1 577 dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l,iq)-qpsn 578 ENDDO 579 580 dys1=0. 581 dys2=0. 582 583 DO ij=1,iim 584 dys1=dys1+sinlondlon(ij)*dyq(ip1jm+ij,l) 585 dys2=dys2+coslondlon(ij)*dyq(ip1jm+ij,l) 586 ENDDO 587 588 DO ij=1,iip1 589 dyq(ip1jm+ij,l)=dys1*sinlon(ij)+dys2*coslon(ij) 590 ENDDO 591 592 DO ij=1,iip1 593 dyq(ip1jm+ij,l)=0. 594 ENDDO 595 ! ym tout cela ne sert pas a grand chose 596 ENDIF 597 598 ! filtrage de la derivee 599 600 ! calcul des pentes limites aux poles 601 ! ym partie inutile 602 ! goto 8888 603 ! fn=1. 604 ! fs=1. 605 ! DO ij=1,iim 606 ! IF(pente_max*adyqv(ij).lt.abs(dyq(ij,l))) THEN 607 ! fn=min(pente_max*adyqv(ij)/abs(dyq(ij,l)),fn) 608 ! ENDIF 609 ! IF(pente_max*adyqv(ij+ip1jm-iip1).lt.abs(dyq(ij+ip1jm,l))) THEN 610 ! fs=min(pente_max*adyqv(ij+ip1jm-iip1)/abs(dyq(ij+ip1jm,l)),fs) 611 ! ENDIF 612 ! ENDDO 613 ! DO ij=1,iip1 614 ! dyq(ij,l)=fn*dyq(ij,l) 615 ! dyq(ip1jm+ij,l)=fs*dyq(ip1jm+ij,l) 616 ! ENDDO 617 ! 8888 continue 618 619 620 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 621 ! En memoire de dIFferents tests sur la 622 ! limitation des pentes aux poles. 623 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 624 ! PRINT*,dyq(1) 625 ! PRINT*,dyqv(iip1+1) 626 ! appn=abs(dyq(1)/dyqv(iip1+1)) 627 ! PRINT*,dyq(ip1jm+1) 628 ! PRINT*,dyqv(ip1jm-iip1+1) 629 ! apps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1)) 630 ! DO ij=2,iim 631 ! appn=amax1(abs(dyq(ij)/dyqv(ij)),appn) 632 ! apps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),apps) 633 ! ENDDO 634 ! appn=min(pente_max/appn,1.) 635 ! apps=min(pente_max/apps,1.) 636 ! 637 ! 638 ! cas ou on a un extremum au pole 639 ! 640 ! IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.) 641 ! & appn=0. 642 ! IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)* 643 ! & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.) 644 ! & apps=0. 645 ! 646 ! limitation des pentes aux poles 647 ! DO ij=1,iip1 648 ! dyq(ij)=appn*dyq(ij) 649 ! dyq(ip1jm+ij)=apps*dyq(ip1jm+ij) 650 ! ENDDO 651 ! 652 ! test 653 ! DO ij=1,iip1 654 ! dyq(iip1+ij)=0. 655 ! dyq(ip1jm+ij-iip1)=0. 656 ! ENDDO 657 ! DO ij=1,ip1jmp1 658 ! dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1)) 659 ! ENDDO 660 ! 661 ! changement 10 07 96 662 ! IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.) 663 ! & THEN 664 ! DO ij=1,iip1 665 ! dyqmax(ij)=0. 666 ! ENDDO 667 ! ELSE 668 ! DO ij=1,iip1 669 ! dyqmax(ij)=pente_max*abs(dyqv(ij)) 670 ! ENDDO 671 ! ENDIF 672 ! 673 ! IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)* 674 ! & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.) 675 ! &THEN 676 ! DO ij=ip1jm+1,ip1jmp1 677 ! dyqmax(ij)=0. 678 ! ENDDO 679 ! ELSE 680 ! DO ij=ip1jm+1,ip1jmp1 681 ! dyqmax(ij)=pente_max*abs(dyqv(ij-iip1)) 682 ! ENDDO 683 ! ENDIF 684 ! fin changement 10 07 96 685 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 686 687 ! calcul des pentes limitees 688 ijb=ij_begin-iip1 689 ije=ij_end+iip1 690 if (pole_nord) ijb=ij_begin+iip1 691 if (pole_sud) ije=ij_end-iip1 692 693 DO ij=ijb,ije 694 IF(dyqv(ij)*dyqv(ij-iip1).gt.0.) THEN 695 dyq(ij,l)=sign(min(abs(dyq(ij,l)),dyqmax(ij)),dyq(ij,l)) 696 ELSE 697 dyq(ij,l)=0. 698 ENDIF 699 ENDDO 700 701 ENDDO 702 !$OMP END DO NOWAIT 703 704 ijb=ij_begin-iip1 705 ije=ij_end 706 if (pole_nord) ijb=ij_begin 707 if (pole_sud) ije=ij_end-iip1 708 709 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 710 DO l=1,llm 711 DO ij=ijb,ije 712 IF(masse_adv_v(ij,l).gt.0) THEN 713 qbyv(ij,l)=q(ij+iip1,l,iq)+dyq(ij+iip1,l)* & 714 0.5*(1.-masse_adv_v(ij,l) & 715 /masse(ij+iip1,l,iq)) 716 ELSE 717 qbyv(ij,l)=q(ij,l,iq)-dyq(ij,l)* & 718 0.5*(1.+masse_adv_v(ij,l)/masse(ij,l,iq)) 494 719 ENDIF 495 496 c 497 c PRINT*,'CALCUL EN LATITUDE' 498 499 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 500 DO l = 1, llm 501 c 502 c -------------------------------- 503 c CALCUL EN LATITUDE 504 c -------------------------------- 505 506 c On commence par calculer la valeur du traceur moyenne sur le premier cercle 507 c de latitude autour du pole (qpns pour le pole nord et qpsn pour 508 c le pole nord) qui sera utilisee pour evaluer les pentes au pole. 509 510 if (pole_nord) then 511 DO i = 1, iim 512 airescb(i) = aire(i+ iip1) * q(i+ iip1,l,iq) 513 ENDDO 514 qpns = SSUM( iim, airescb ,1 ) / airej2 515 endif 516 517 if (pole_sud) then 518 DO i = 1, iim 519 airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l,iq) 520 ENDDO 521 qpsn = SSUM( iim, airesch ,1 ) / airejjm 522 endif 523 524 c calcul des pentes aux points v 525 526 ijb=ij_begin-2*iip1 527 ije=ij_end+iip1 528 if (pole_nord) ijb=ij_begin 529 if (pole_sud) ije=ij_end-iip1 530 531 ! on a besoin de q entre ij_begin-2*iip1 et ij_end+2*iip1 532 ! Si pole sud, entre ij_begin-2*iip1 et ij_end 533 ! Si pole Nord, entre ij_begin et ij_end+2*iip1 720 qbyv(ij,l)=masse_adv_v(ij,l)*qbyv(ij,l) 721 ENDDO 722 ENDDO 723 !$OMP END DO NOWAIT 724 725 ! CRisi: appel récursif de l'advection sur les fils. 726 ! Il faut faire ça avant d'avoir mis à jour q et masse 727 ! write(*,*)'vly 689: iq,nqChildren(iq)=',iq,tracers(iq)%nqChildren 728 729 ijb=ij_begin-2*iip1 730 ije=ij_end+2*iip1 731 ijbm=ij_begin-iip1 732 ijem=ij_end+iip1 733 if (pole_nord) ijb=ij_begin 734 if (pole_sud) ije=ij_end 735 if (pole_nord) ijbm=ij_begin 736 if (pole_sud) ijem=ij_end 737 738 do ifils=1,tracers(iq)%nqDescen 739 iq2=tracers(iq)%iqDescen(ifils) 740 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 741 DO l=1,llm 742 ! ! modif des bornes: CRisi 16 nov 2020 743 ! ! d'abord masse avec bornes corrigées 744 DO ij=ijbm,ijem 745 ! !MVals: veiller a ce qu'on n'ait pas de denominateur nul 746 masse(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass) 747 enddo 748 749 ! ! ensuite Ratio avec anciennes bornes 534 750 DO ij=ijb,ije 535 dyqv(ij)=q(ij,l,iq)-q(ij+iip1,l,iq) 536 adyqv(ij)=abs(dyqv(ij)) 537 ENDDO 538 539 540 c calcul des pentes aux points scalaires 541 ijb=ij_begin-iip1 542 ije=ij_end+iip1 543 if (pole_nord) ijb=ij_begin+iip1 544 if (pole_sud) ije=ij_end-iip1 545 751 ! !MVals: veiller a ce qu'on n'ait pas de denominateur nul 752 if (q(ij,l,iq).gt.min_qParent) then ! modif 13 nov 2020 753 Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq) 754 else 755 Ratio(ij,l,iq2)=min_ratio 756 endif 757 enddo !DO ij=ijbm,ijem 758 enddo !DO l=1,llm 759 !$OMP END DO NOWAIT 760 enddo 761 762 do ifils=1,tracers(iq)%nqChildren 763 iq2=tracers(iq)%iqDescen(ifils) 764 call vly_loc(Ratio,pente_max,masse,qbyv,iq2) 765 enddo 766 ! end CRisi 767 768 ijb=ij_begin 769 ije=ij_end 770 if (pole_nord) ijb=ij_begin+iip1 771 if (pole_sud) ije=ij_end-iip1 772 773 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 774 DO l=1,llm 775 DO ij=ijb,ije 776 newmasse=masse(ij,l,iq) & 777 +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l) 778 779 q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+qbyv(ij,l) & 780 -qbyv(ij-iip1,l))/newmasse 781 782 masse(ij,l,iq)=newmasse 783 784 ENDDO 785 786 787 !.-. ancienne version 788 ! convpn=SSUM(iim,qbyv(1,l),1)/apoln 789 ! convmpn=ssum(iim,masse_adv_v(1,l),1)/apoln 790 if (pole_nord) then 791 convpn=SSUM(iim,qbyv(1,l),1) 792 convmpn=ssum(iim,masse_adv_v(1,l),1) 793 massepn=ssum(iim,masse(1,l,iq),1) 794 qpn=0. 795 do ij=1,iim 796 qpn=qpn+masse(ij,l,iq)*q(ij,l,iq) 797 enddo 798 qpn=(qpn+convpn)/(massepn+convmpn) 799 do ij=1,iip1 800 q(ij,l,iq)=qpn 801 enddo 802 endif 803 804 ! convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)/apols 805 ! convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)/apols 806 807 if (pole_sud) then 808 809 convps=-SSUM(iim,qbyv(ip1jm-iim,l),1) 810 convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1) 811 masseps=ssum(iim, masse(ip1jm+1,l,iq),1) 812 qps=0. 813 do ij = ip1jm+1,ip1jmp1-1 814 qps=qps+masse(ij,l,iq)*q(ij,l,iq) 815 enddo 816 qps=(qps+convps)/(masseps+convmps) 817 do ij=ip1jm+1,ip1jmp1 818 q(ij,l,iq)=qps 819 enddo 820 endif 821 !.-. fin ancienne version 822 823 !._. nouvelle version 824 ! convpn=SSUM(iim,qbyv(1,l),1) 825 ! convmpn=ssum(iim,masse_adv_v(1,l),1) 826 ! oldmasse=ssum(iim,masse(1,l),1) 827 ! newmasse=oldmasse+convmpn 828 ! newq=(q(1,l)*oldmasse+convpn)/newmasse 829 ! newmasse=newmasse/apoln 830 ! DO ij = 1,iip1 831 ! q(ij,l)=newq 832 ! masse(ij,l,iq)=newmasse*aire(ij) 833 ! ENDDO 834 ! convps=-SSUM(iim,qbyv(ip1jm-iim,l),1) 835 ! convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1) 836 ! oldmasse=ssum(iim,masse(ip1jm-iim,l),1) 837 ! newmasse=oldmasse+convmps 838 ! newq=(q(ip1jmp1,l)*oldmasse+convps)/newmasse 839 ! newmasse=newmasse/apols 840 ! DO ij = ip1jm+1,ip1jmp1 841 ! q(ij,l)=newq 842 ! masse(ij,l,iq)=newmasse*aire(ij) 843 ! ENDDO 844 !._. fin nouvelle version 845 ENDDO 846 !$OMP END DO NOWAIT 847 848 ! retablir les fils en rapport de melange par rapport a l'air: 849 ijb=ij_begin 850 ije=ij_end 851 ! if (pole_nord) ijb=ij_begin 852 ! if (pole_sud) ije=ij_end 853 854 do ifils=1,tracers(iq)%nqDescen 855 iq2=tracers(iq)%iqDescen(ifils) 856 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 857 DO l=1,llm 546 858 DO ij=ijb,ije 547 dyq(ij,l)=.5*(dyqv(ij-iip1)+dyqv(ij)) 548 dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij)) 549 dyqmax(ij)=pente_max*dyqmax(ij) 550 ENDDO 551 552 c calcul des pentes aux poles 553 IF (pole_nord) THEN 554 DO ij=1,iip1 555 dyq(ij,l)=qpns-q(ij+iip1,l,iq) 556 ENDDO 557 558 dyn1=0. 559 dyn2=0. 560 DO ij=1,iim 561 dyn1=dyn1+sinlondlon(ij)*dyq(ij,l) 562 dyn2=dyn2+coslondlon(ij)*dyq(ij,l) 563 ENDDO 564 DO ij=1,iip1 565 dyq(ij,l)=dyn1*sinlon(ij)+dyn2*coslon(ij) 566 ENDDO 567 568 DO ij=1,iip1 569 dyq(ij,l)=0. 570 ENDDO 571 c ym tout cela ne sert pas a grand chose 859 q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2) 860 enddo 861 enddo 862 !$OMP END DO NOWAIT 863 enddo 864 865 866 RETURN 867 END SUBROUTINE vly_loc 868 869 870 871 RECURSIVE SUBROUTINE vlz_loc(q,pente_max,masse,w,ijb_x,ije_x,iq) 872 ! 873 ! Auteurs: P.Le Van, F.Hourdin, F.Forget 874 ! 875 ! ******************************************************************** 876 ! Shema d'advection " pseudo amont " . 877 ! ******************************************************************** 878 ! q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... 879 ! dq sont des arguments de sortie pour le s-pg .... 880 ! 881 ! 882 ! -------------------------------------------------------------------- 883 USE parallel_lmdz 884 USE vlz_mod 885 USE infotrac, ONLY : nqtot,tracers, & ! CRisi & 886 min_qParent,min_qMass,min_ratio ! MVals et CRisi 887 888 IMPLICIT NONE 889 ! 890 include "dimensions.h" 891 include "paramet.h" 892 include "iniprint.h" 893 ! 894 ! 895 ! Arguments: 896 ! ---------- 897 REAL :: masse(ijb_u:ije_u,llm,nqtot),pente_max 898 REAL :: q(ijb_u:ije_u,llm,nqtot) 899 REAL :: w(ijb_u:ije_u,llm+1,nqtot) 900 INTEGER :: iq 901 ! 902 ! Local 903 ! --------- 904 ! 905 INTEGER :: i,ij,l,j,ii 906 907 REAL,DIMENSION(ijb_u:ije_u,llm+1) :: wresi,morig,qorig,dzqorig 908 INTEGER,DIMENSION(ijb_u:ije_u,llm+1) :: lorig 909 INTEGER,SAVE :: countcfl 910 !$OMP THREADPRIVATE(countcfl) 911 ! 912 REAL :: newmasse 913 914 REAL :: dzqmax 915 REAL :: sigw 916 917 LOGICAL :: testcpu 918 SAVE testcpu 919 !$OMP THREADPRIVATE(testcpu) 920 REAL :: temps0,temps1,temps2,temps3,temps4,temps5,second 921 SAVE temps0,temps1,temps2,temps3,temps4,temps5 922 !$OMP THREADPRIVATE(temps0,temps1,temps2,temps3,temps4,temps5) 923 924 REAL :: SSUM 925 EXTERNAL SSUM 926 927 DATA testcpu/.false./ 928 DATA temps0,temps1,temps2,temps3,temps4,temps5/0.,0.,0.,0.,0.,0./ 929 INTEGER :: ijb,ije,ijb_x,ije_x 930 LOGICAL,SAVE :: first=.TRUE. 931 !$OMP THREADPRIVATE(first) 932 933 ! !REAL masseq(ijb_u:ije_u,llm,nqtot),Ratio(ijb_u:ije_u,llm,nqtot) ! CRisi 934 ! ! Ces varibles doivent être déclarées en pointer et en save dans 935 ! ! vlz_loc si on veut qu'elles soient vues par tous les threads. 936 INTEGER :: ifils,iq2 ! CRisi 937 938 939 IF (first) THEN 940 first=.FALSE. 941 ENDIF 942 ! On oriente tout dans le sens de la pression c'est a dire dans le 943 ! sens de W 944 945 ! !write(*,*) 'vlsplt 926: entree dans vlz_loc, iq=',iq 946 #ifdef BIDON 947 IF(testcpu) THEN 948 temps0=second(0.) 949 ENDIF 950 #endif 951 952 ijb=ijb_x 953 ije=ije_x 954 955 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 956 DO l=2,llm 957 DO ij=ijb,ije 958 dzqw(ij,l)=q(ij,l-1,iq)-q(ij,l,iq) 959 adzqw(ij,l)=abs(dzqw(ij,l)) 960 ENDDO 961 ENDDO 962 !$OMP END DO 963 964 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 965 DO l=2,llm-1 966 DO ij=ijb,ije 967 #ifdef CRAY 968 dzq(ij,l)=0.5* & 969 cvmgp(dzqw(ij,l)+dzqw(ij,l+1),0.,dzqw(ij,l)*dzqw(ij,l+1)) 970 #else 971 IF(dzqw(ij,l)*dzqw(ij,l+1).gt.0.) THEN 972 dzq(ij,l)=0.5*(dzqw(ij,l)+dzqw(ij,l+1)) 973 ELSE 974 dzq(ij,l)=0. 975 ENDIF 976 #endif 977 dzqmax=pente_max*min(adzqw(ij,l),adzqw(ij,l+1)) 978 dzq(ij,l)=sign(min(abs(dzq(ij,l)),dzqmax),dzq(ij,l)) 979 ENDDO 980 ENDDO 981 !$OMP END DO NOWAIT 982 983 !$OMP MASTER 984 DO ij=ijb,ije 985 dzq(ij,1)=0. 986 dzq(ij,llm)=0. 987 ENDDO 988 !$OMP END MASTER 989 !$OMP BARRIER 990 #ifdef BIDON 991 IF(testcpu) THEN 992 temps1=temps1+second(0.)-temps0 993 ENDIF 994 #endif 995 996 !-------------------------------------------------------- 997 ! On repere les points qui violent le CFL (|w| > masse) 998 !-------------------------------------------------------- 999 1000 countcfl=0 1001 ! print*,'vlz nouveau' 1002 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 1003 DO l = 2,llm 1004 DO ij = ijb,ije 1005 IF( (w(ij,l,iq)>0.AND.w(ij,l,iq)>masse(ij,l,iq)) & 1006 .OR. (w(ij,l,iq)<=0.AND.ABS(w(ij,l,iq))>masse(ij,l-1,iq)) ) & 1007 countcfl=countcfl+1 1008 ENDDO 1009 ENDDO 1010 !$OMP END DO NOWAIT 1011 1012 ! --------------------------------------------------------------- 1013 ! Identification des mailles ou on viole le CFL : w > masse 1014 ! --------------------------------------------------------------- 1015 1016 IF (countcfl==0) THEN 1017 1018 ! --------------------------------------------------------------- 1019 ! .... calcul des termes d'advection verticale ....... 1020 ! Dans le cas où le |w| < masse partout. 1021 ! Version d'origine 1022 ! Pourrait etre enleve si on voit que le code plus general 1023 ! est aussi rapide 1024 ! --------------------------------------------------------------- 1025 1026 ! calcul de - d( q * w )/ d(sigma) qu'on ajoute a dq pour calculer dq 1027 1028 ! !write(*,*) 'vlz 982,ijb,ije=',ijb,ije 1029 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 1030 DO l = 1,llm-1 1031 do ij = ijb,ije 1032 IF(w(ij,l+1,iq).gt.0.) THEN 1033 sigw=w(ij,l+1,iq)/masse(ij,l+1,iq) 1034 wq(ij,l+1,iq)=w(ij,l+1,iq)*(q(ij,l+1,iq) & 1035 +0.5*(1.-sigw)*dzq(ij,l+1)) 1036 ELSE 1037 sigw=w(ij,l+1,iq)/masse(ij,l,iq) 1038 wq(ij,l+1,iq)=w(ij,l+1,iq)*(q(ij,l,iq) & 1039 -0.5*(1.+sigw)*dzq(ij,l)) 572 1040 ENDIF 573 574 IF (pole_sud) THEN 575 576 DO ij=1,iip1 577 dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l,iq)-qpsn 578 ENDDO 579 580 dys1=0. 581 dys2=0. 582 583 DO ij=1,iim 584 dys1=dys1+sinlondlon(ij)*dyq(ip1jm+ij,l) 585 dys2=dys2+coslondlon(ij)*dyq(ip1jm+ij,l) 586 ENDDO 587 588 DO ij=1,iip1 589 dyq(ip1jm+ij,l)=dys1*sinlon(ij)+dys2*coslon(ij) 590 ENDDO 591 592 DO ij=1,iip1 593 dyq(ip1jm+ij,l)=0. 594 ENDDO 595 c ym tout cela ne sert pas a grand chose 1041 ENDDO 1042 ENDDO 1043 !$OMP END DO NOWAIT 1044 ! !write(*,*) 'vlz 1001' 1045 1046 ELSE ! countcfl>=1 1047 1048 IF (prt_level>9) THEN 1049 WRITE(lunout,*)'vlz passage dans le non local' 1050 ENDIF 1051 ! --------------------------------------------------------------- 1052 ! Debut du traitement du cas ou on viole le CFL : w > masse 1053 ! --------------------------------------------------------------- 1054 1055 ! Initialisation 1056 1057 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 1058 DO l = 2,llm 1059 DO ij = ijb,ije 1060 wresi(ij,l)=w(ij,l,iq) 1061 wq(ij,l,iq)=0. 1062 IF(w(ij,l,iq).gt.0.) THEN 1063 lorig(ij,l)=l 1064 morig(ij,l)=masse(ij,l,iq) 1065 qorig(ij,l)=q(ij,l,iq) 1066 dzqorig(ij,l)=dzq(ij,l) 1067 ELSE 1068 lorig(ij,l)=l-1 1069 morig(ij,l)=masse(ij,l-1,iq) 1070 qorig(ij,l)=q(ij,l-1,iq) 1071 dzqorig(ij,l)=dzq(ij,l-1) 1072 ENDIF 1073 ENDDO 1074 ENDDO 1075 !$OMP END DO NOWAIT 1076 1077 ! Reindicage vertical en accumulant les flux sur 1078 ! les mailles qui viollent le CFL 1079 ! on itère jusqu'à ce que tous les poins satisfassent 1080 ! le critère 1081 DO WHILE (countcfl>=1) 1082 IF (prt_level>9) THEN 1083 WRITE(lunout,*)'On viole le CFL Vertical sur ',countcfl,' pts' 1084 ENDIF 1085 countcfl=0 1086 1087 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 1088 DO l = 2,llm 1089 DO ij = ijb,ije 1090 IF (ABS(wresi(ij,l))>morig(ij,l)) THEN 1091 countcfl=countcfl+1 1092 ! rm : les 8 lignes ci dessous pourraient sans doute s'ecrire 1093 ! avec la fonction sign 1094 IF(w(ij,l,iq)>0.) THEN 1095 wresi(ij,l)=wresi(ij,l)-morig(ij,l) 1096 wq(ij,l,iq)=wq(ij,l,iq)+morig(ij,l)*qorig(ij,l) 1097 lorig(ij,l)=lorig(ij,l)+1 1098 ELSE 1099 wresi(ij,l)=wresi(ij,l)+morig(ij,l) 1100 wq(ij,l,iq)=wq(ij,l,iq)-morig(ij,l)*qorig(ij,l) 1101 lorig(ij,l)=lorig(ij,l)-1 1102 ENDIF 1103 ! ! CRisi 24nov2020: ajout d'un message d'erreur clair au lieu d'un plantage 1104 ! ! pour seg fault 1105 if (lorig(ij,l).eq.0) then 1106 call abort_gcm("vlz in vlsplt_loc", & 1107 "unfixable violation of CFL",1) 1108 endif 1109 morig(ij,l)=masse(ij,lorig(ij,l),iq) 1110 qorig(ij,l)=q(ij,lorig(ij,l),iq) 1111 dzqorig(ij,l)=dzq(ij,lorig(ij,l)) 596 1112 ENDIF 597 598 c filtrage de la derivee 599 600 c calcul des pentes limites aux poles 601 c ym partie inutile 602 c goto 8888 603 c fn=1. 604 c fs=1. 605 c DO ij=1,iim 606 c IF(pente_max*adyqv(ij).lt.abs(dyq(ij,l))) THEN 607 c fn=min(pente_max*adyqv(ij)/abs(dyq(ij,l)),fn) 608 c ENDIF 609 c IF(pente_max*adyqv(ij+ip1jm-iip1).lt.abs(dyq(ij+ip1jm,l))) THEN 610 c fs=min(pente_max*adyqv(ij+ip1jm-iip1)/abs(dyq(ij+ip1jm,l)),fs) 611 c ENDIF 612 c ENDDO 613 c DO ij=1,iip1 614 c dyq(ij,l)=fn*dyq(ij,l) 615 c dyq(ip1jm+ij,l)=fs*dyq(ip1jm+ij,l) 616 c ENDDO 617 c 8888 continue 618 619 620 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 621 C En memoire de dIFferents tests sur la 622 C limitation des pentes aux poles. 623 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 624 C PRINT*,dyq(1) 625 C PRINT*,dyqv(iip1+1) 626 C appn=abs(dyq(1)/dyqv(iip1+1)) 627 C PRINT*,dyq(ip1jm+1) 628 C PRINT*,dyqv(ip1jm-iip1+1) 629 C apps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1)) 630 C DO ij=2,iim 631 C appn=amax1(abs(dyq(ij)/dyqv(ij)),appn) 632 C apps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),apps) 633 C ENDDO 634 C appn=min(pente_max/appn,1.) 635 C apps=min(pente_max/apps,1.) 636 C 637 C 638 C cas ou on a un extremum au pole 639 C 640 C IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.) 641 C & appn=0. 642 C IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)* 643 C & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.) 644 C & apps=0. 645 C 646 C limitation des pentes aux poles 647 C DO ij=1,iip1 648 C dyq(ij)=appn*dyq(ij) 649 C dyq(ip1jm+ij)=apps*dyq(ip1jm+ij) 650 C ENDDO 651 C 652 C test 653 C DO ij=1,iip1 654 C dyq(iip1+ij)=0. 655 C dyq(ip1jm+ij-iip1)=0. 656 C ENDDO 657 C DO ij=1,ip1jmp1 658 C dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1)) 659 C ENDDO 660 C 661 C changement 10 07 96 662 C IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.) 663 C & THEN 664 C DO ij=1,iip1 665 C dyqmax(ij)=0. 666 C ENDDO 667 C ELSE 668 C DO ij=1,iip1 669 C dyqmax(ij)=pente_max*abs(dyqv(ij)) 670 C ENDDO 671 C ENDIF 672 C 673 C IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)* 674 C & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.) 675 C &THEN 676 C DO ij=ip1jm+1,ip1jmp1 677 C dyqmax(ij)=0. 678 C ENDDO 679 C ELSE 680 C DO ij=ip1jm+1,ip1jmp1 681 C dyqmax(ij)=pente_max*abs(dyqv(ij-iip1)) 682 C ENDDO 683 C ENDIF 684 C fin changement 10 07 96 685 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 686 687 c calcul des pentes limitees 688 ijb=ij_begin-iip1 689 ije=ij_end+iip1 690 if (pole_nord) ijb=ij_begin+iip1 691 if (pole_sud) ije=ij_end-iip1 692 1113 ENDDO 1114 ENDDO 1115 !$OMP END DO NOWAIT 1116 1117 ENDDO ! WHILE (countcfl>=1) 1118 1119 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 1120 DO l = 2,llm 1121 do ij = ijb,ije 1122 sigw=wresi(ij,l)/morig(ij,l) 1123 IF(w(ij,l,iq).gt.0.) THEN 1124 wq(ij,l,iq)=wq(ij,l,iq)+wresi(ij,l)*(qorig(ij,l) & 1125 +0.5*(1.-sigw)*dzqorig(ij,l)) 1126 ELSE 1127 wq(ij,l,iq)=wq(ij,l,iq)+wresi(ij,l)*(qorig(ij,l) & 1128 -0.5*(1.+sigw)*dzqorig(ij,l)) 1129 ENDIF 1130 ENDDO 1131 ENDDO 1132 !$OMP END DO NOWAIT 1133 1134 1135 ENDIF ! councfl=0 1136 1137 1138 1139 !$OMP MASTER 1140 DO ij=ijb,ije 1141 wq(ij,llm+1,iq)=0. 1142 wq(ij,1,iq)=0. 1143 ENDDO 1144 !$OMP END MASTER 1145 !$OMP BARRIER 1146 1147 ! CRisi: appel récursif de l'advection sur les fils. 1148 ! Il faut faire ça avant d'avoir mis à jour q et masse 1149 ! write(*,*)'vlsplt 942: iq,nqChildren(iq)=',iq,tracers(iq)%nqChildren 1150 do ifils=1,tracers(iq)%nqDescen 1151 iq2=tracers(iq)%iqDescen(ifils) 1152 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 1153 DO l=1,llm 693 1154 DO ij=ijb,ije 694 IF(dyqv(ij)*dyqv(ij-iip1).gt.0.) THEN 695 dyq(ij,l)=sign(min(abs(dyq(ij,l)),dyqmax(ij)),dyq(ij,l)) 696 ELSE 697 dyq(ij,l)=0. 698 ENDIF 699 ENDDO 700 701 ENDDO 702 c$OMP END DO NOWAIT 703 704 ijb=ij_begin-iip1 705 ije=ij_end 706 if (pole_nord) ijb=ij_begin 707 if (pole_sud) ije=ij_end-iip1 708 709 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 710 DO l=1,llm 711 DO ij=ijb,ije 712 IF(masse_adv_v(ij,l).gt.0) THEN 713 qbyv(ij,l)=q(ij+iip1,l,iq)+dyq(ij+iip1,l)* 714 , 0.5*(1.-masse_adv_v(ij,l) 715 , /masse(ij+iip1,l,iq)) 716 ELSE 717 qbyv(ij,l)=q(ij,l,iq)-dyq(ij,l)* 718 , 0.5*(1.+masse_adv_v(ij,l)/masse(ij,l,iq)) 719 ENDIF 720 qbyv(ij,l)=masse_adv_v(ij,l)*qbyv(ij,l) 721 ENDDO 722 ENDDO 723 c$OMP END DO NOWAIT 724 725 ! CRisi: appel récursif de l'advection sur les fils. 726 ! Il faut faire ça avant d'avoir mis à jour q et masse 727 ! write(*,*)'vly 689: iq,nqChildren(iq)=',iq,tracers(iq)%nqChildren 728 729 ijb=ij_begin-2*iip1 730 ije=ij_end+2*iip1 731 ijbm=ij_begin-iip1 732 ijem=ij_end+iip1 733 if (pole_nord) ijb=ij_begin 734 if (pole_sud) ije=ij_end 735 if (pole_nord) ijbm=ij_begin 736 if (pole_sud) ijem=ij_end 737 738 do ifils=1,tracers(iq)%nqDescen 739 iq2=tracers(iq)%iqDescen(ifils) 740 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 741 DO l=1,llm 742 ! modif des bornes: CRisi 16 nov 2020 743 ! d'abord masse avec bornes corrigées 744 DO ij=ijbm,ijem 745 !MVals: veiller a ce qu'on n'ait pas de denominateur nul 746 masse(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass) 747 enddo 748 749 ! ensuite Ratio avec anciennes bornes 750 DO ij=ijb,ije 751 !MVals: veiller a ce qu'on n'ait pas de denominateur nul 752 if (q(ij,l,iq).gt.min_qParent) then ! modif 13 nov 2020 753 Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq) 754 else 755 Ratio(ij,l,iq2)=min_ratio 756 endif 757 enddo !DO ij=ijbm,ijem 758 enddo !DO l=1,llm 759 c$OMP END DO NOWAIT 1155 ! !MVals: veiller a ce qu'on n'ait pas de denominateur nul 1156 masse(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass) 1157 if (q(ij,l,iq).gt.min_qParent) then 1158 Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq) 1159 else 1160 Ratio(ij,l,iq2)=min_ratio 1161 endif 1162 ! !wq(ij,l,iq2)=wq(ij,l,iq) ! correction bug le 15mai2015 1163 w(ij,l,iq2)=wq(ij,l,iq) 760 1164 enddo 761 762 do ifils=1,tracers(iq)%nqChildren 763 iq2=tracers(iq)%iqDescen(ifils) 764 call vly_loc(Ratio,pente_max,masse,qbyv,iq2) 1165 enddo 1166 !$OMP END DO NOWAIT 1167 enddo 1168 !$OMP BARRIER 1169 1170 do ifils=1,tracers(iq)%nqChildren 1171 iq2=tracers(iq)%iqDescen(ifils) 1172 call vlz_loc(Ratio,pente_max,masse,w,ijb_x,ije_x,iq2) 1173 enddo 1174 ! end CRisi 1175 1176 ! CRisi: On rajoute ici une barrière car on veut être sur que tous les 1177 ! wq soient synchronisés 1178 1179 !$OMP BARRIER 1180 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 1181 DO l=1,llm 1182 DO ij=ijb,ije 1183 newmasse=masse(ij,l,iq)+w(ij,l+1,iq)-w(ij,l,iq) 1184 q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq) & 1185 +wq(ij,l+1,iq)-wq(ij,l,iq)) & 1186 /newmasse 1187 masse(ij,l,iq)=newmasse 1188 ENDDO 1189 ENDDO 1190 !$OMP END DO NOWAIT 1191 1192 1193 ! retablir les fils en rapport de melange par rapport a l'air: 1194 do ifils=1,tracers(iq)%nqDescen 1195 iq2=tracers(iq)%iqDescen(ifils) 1196 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 1197 DO l=1,llm 1198 DO ij=ijb,ije 1199 q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2) 765 1200 enddo 766 ! end CRisi 767 768 ijb=ij_begin 769 ije=ij_end 770 if (pole_nord) ijb=ij_begin+iip1 771 if (pole_sud) ije=ij_end-iip1 772 773 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 774 DO l=1,llm 775 DO ij=ijb,ije 776 newmasse=masse(ij,l,iq) 777 & +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l) 778 779 q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+qbyv(ij,l) 780 & -qbyv(ij-iip1,l))/newmasse 781 782 masse(ij,l,iq)=newmasse 783 784 ENDDO 785 786 787 c.-. ancienne version 788 c convpn=SSUM(iim,qbyv(1,l),1)/apoln 789 c convmpn=ssum(iim,masse_adv_v(1,l),1)/apoln 790 if (pole_nord) then 791 convpn=SSUM(iim,qbyv(1,l),1) 792 convmpn=ssum(iim,masse_adv_v(1,l),1) 793 massepn=ssum(iim,masse(1,l,iq),1) 794 qpn=0. 795 do ij=1,iim 796 qpn=qpn+masse(ij,l,iq)*q(ij,l,iq) 797 enddo 798 qpn=(qpn+convpn)/(massepn+convmpn) 799 do ij=1,iip1 800 q(ij,l,iq)=qpn 801 enddo 802 endif 803 804 c convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)/apols 805 c convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)/apols 806 807 if (pole_sud) then 808 809 convps=-SSUM(iim,qbyv(ip1jm-iim,l),1) 810 convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1) 811 masseps=ssum(iim, masse(ip1jm+1,l,iq),1) 812 qps=0. 813 do ij = ip1jm+1,ip1jmp1-1 814 qps=qps+masse(ij,l,iq)*q(ij,l,iq) 815 enddo 816 qps=(qps+convps)/(masseps+convmps) 817 do ij=ip1jm+1,ip1jmp1 818 q(ij,l,iq)=qps 819 enddo 820 endif 821 c.-. fin ancienne version 822 823 c._. nouvelle version 824 c convpn=SSUM(iim,qbyv(1,l),1) 825 c convmpn=ssum(iim,masse_adv_v(1,l),1) 826 c oldmasse=ssum(iim,masse(1,l),1) 827 c newmasse=oldmasse+convmpn 828 c newq=(q(1,l)*oldmasse+convpn)/newmasse 829 c newmasse=newmasse/apoln 830 c DO ij = 1,iip1 831 c q(ij,l)=newq 832 c masse(ij,l,iq)=newmasse*aire(ij) 833 c ENDDO 834 c convps=-SSUM(iim,qbyv(ip1jm-iim,l),1) 835 c convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1) 836 c oldmasse=ssum(iim,masse(ip1jm-iim,l),1) 837 c newmasse=oldmasse+convmps 838 c newq=(q(ip1jmp1,l)*oldmasse+convps)/newmasse 839 c newmasse=newmasse/apols 840 c DO ij = ip1jm+1,ip1jmp1 841 c q(ij,l)=newq 842 c masse(ij,l,iq)=newmasse*aire(ij) 843 c ENDDO 844 c._. fin nouvelle version 845 ENDDO 846 c$OMP END DO NOWAIT 847 848 ! retablir les fils en rapport de melange par rapport a l'air: 849 ijb=ij_begin 850 ije=ij_end 851 ! if (pole_nord) ijb=ij_begin 852 ! if (pole_sud) ije=ij_end 853 854 do ifils=1,tracers(iq)%nqDescen 855 iq2=tracers(iq)%iqDescen(ifils) 856 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 857 DO l=1,llm 858 DO ij=ijb,ije 859 q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2) 860 enddo 861 enddo 862 c$OMP END DO NOWAIT 863 enddo 864 865 866 RETURN 867 END 868 869 870 871 RECURSIVE SUBROUTINE vlz_loc(q,pente_max,masse,w,ijb_x,ije_x,iq) 872 c 873 c Auteurs: P.Le Van, F.Hourdin, F.Forget 874 c 875 c ******************************************************************** 876 c Shema d'advection " pseudo amont " . 877 c ******************************************************************** 878 c q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... 879 c dq sont des arguments de sortie pour le s-pg .... 880 c 881 c 882 c -------------------------------------------------------------------- 883 USE parallel_lmdz 884 USE vlz_mod 885 USE infotrac, ONLY : nqtot,tracers, ! CRisi & 886 & min_qParent,min_qMass,min_ratio ! MVals et CRisi 887 888 IMPLICIT NONE 889 c 890 include "dimensions.h" 891 include "paramet.h" 892 include "iniprint.h" 893 c 894 c 895 c Arguments: 896 c ---------- 897 REAL masse(ijb_u:ije_u,llm,nqtot),pente_max 898 REAL q(ijb_u:ije_u,llm,nqtot) 899 REAL w(ijb_u:ije_u,llm+1,nqtot) 900 INTEGER iq 901 c 902 c Local 903 c --------- 904 c 905 INTEGER i,ij,l,j,ii 906 907 REAL,DIMENSION(ijb_u:ije_u,llm+1) :: wresi,morig,qorig,dzqorig 908 INTEGER,DIMENSION(ijb_u:ije_u,llm+1) :: lorig 909 INTEGER,SAVE :: countcfl 910 !$OMP THREADPRIVATE(countcfl) 911 c 912 REAL newmasse 913 914 REAL dzqmax 915 REAL sigw 916 917 LOGICAL testcpu 918 SAVE testcpu 919 c$OMP THREADPRIVATE(testcpu) 920 REAL temps0,temps1,temps2,temps3,temps4,temps5,second 921 SAVE temps0,temps1,temps2,temps3,temps4,temps5 922 c$OMP THREADPRIVATE(temps0,temps1,temps2,temps3,temps4,temps5) 923 924 REAL SSUM 925 EXTERNAL SSUM 926 927 DATA testcpu/.false./ 928 DATA temps0,temps1,temps2,temps3,temps4,temps5/0.,0.,0.,0.,0.,0./ 929 INTEGER ijb,ije,ijb_x,ije_x 930 LOGICAL,SAVE :: first=.TRUE. 931 !$OMP THREADPRIVATE(first) 932 933 !REAL masseq(ijb_u:ije_u,llm,nqtot),Ratio(ijb_u:ije_u,llm,nqtot) ! CRisi 934 ! Ces varibles doivent être déclarées en pointer et en save dans 935 ! vlz_loc si on veut qu'elles soient vues par tous les threads. 936 INTEGER ifils,iq2 ! CRisi 937 938 939 IF (first) THEN 940 first=.FALSE. 941 ENDIF 942 c On oriente tout dans le sens de la pression c'est a dire dans le 943 c sens de W 944 945 !write(*,*) 'vlsplt 926: entree dans vlz_loc, iq=',iq 946 #ifdef BIDON 947 IF(testcpu) THEN 948 temps0=second(0.) 949 ENDIF 950 #endif 951 952 ijb=ijb_x 953 ije=ije_x 954 955 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 956 DO l=2,llm 957 DO ij=ijb,ije 958 dzqw(ij,l)=q(ij,l-1,iq)-q(ij,l,iq) 959 adzqw(ij,l)=abs(dzqw(ij,l)) 960 ENDDO 961 ENDDO 962 c$OMP END DO 963 964 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 965 DO l=2,llm-1 966 DO ij=ijb,ije 967 #ifdef CRAY 968 dzq(ij,l)=0.5* 969 , cvmgp(dzqw(ij,l)+dzqw(ij,l+1),0.,dzqw(ij,l)*dzqw(ij,l+1)) 970 #else 971 IF(dzqw(ij,l)*dzqw(ij,l+1).gt.0.) THEN 972 dzq(ij,l)=0.5*(dzqw(ij,l)+dzqw(ij,l+1)) 973 ELSE 974 dzq(ij,l)=0. 975 ENDIF 976 #endif 977 dzqmax=pente_max*min(adzqw(ij,l),adzqw(ij,l+1)) 978 dzq(ij,l)=sign(min(abs(dzq(ij,l)),dzqmax),dzq(ij,l)) 979 ENDDO 980 ENDDO 981 c$OMP END DO NOWAIT 982 983 c$OMP MASTER 984 DO ij=ijb,ije 985 dzq(ij,1)=0. 986 dzq(ij,llm)=0. 987 ENDDO 988 c$OMP END MASTER 989 c$OMP BARRIER 990 #ifdef BIDON 991 IF(testcpu) THEN 992 temps1=temps1+second(0.)-temps0 993 ENDIF 994 #endif 995 996 !-------------------------------------------------------- 997 ! On repere les points qui violent le CFL (|w| > masse) 998 !-------------------------------------------------------- 999 1000 countcfl=0 1001 ! print*,'vlz nouveau' 1002 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 1003 DO l = 2,llm 1004 DO ij = ijb,ije 1005 IF( (w(ij,l,iq)>0.AND.w(ij,l,iq)>masse(ij,l,iq)) 1006 s .OR. (w(ij,l,iq)<=0.AND.ABS(w(ij,l,iq))>masse(ij,l-1,iq)) ) 1007 s countcfl=countcfl+1 1008 ENDDO 1009 ENDDO 1010 c$OMP END DO NOWAIT 1011 1012 c --------------------------------------------------------------- 1013 c Identification des mailles ou on viole le CFL : w > masse 1014 c --------------------------------------------------------------- 1015 1016 IF (countcfl==0) THEN 1017 1018 c --------------------------------------------------------------- 1019 c .... calcul des termes d'advection verticale ....... 1020 c Dans le cas où le |w| < masse partout. 1021 c Version d'origine 1022 c Pourrait etre enleve si on voit que le code plus general 1023 c est aussi rapide 1024 c --------------------------------------------------------------- 1025 1026 c calcul de - d( q * w )/ d(sigma) qu'on ajoute a dq pour calculer dq 1027 1028 !write(*,*) 'vlz 982,ijb,ije=',ijb,ije 1029 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 1030 DO l = 1,llm-1 1031 do ij = ijb,ije 1032 IF(w(ij,l+1,iq).gt.0.) THEN 1033 sigw=w(ij,l+1,iq)/masse(ij,l+1,iq) 1034 wq(ij,l+1,iq)=w(ij,l+1,iq)*(q(ij,l+1,iq) 1035 : +0.5*(1.-sigw)*dzq(ij,l+1)) 1036 ELSE 1037 sigw=w(ij,l+1,iq)/masse(ij,l,iq) 1038 wq(ij,l+1,iq)=w(ij,l+1,iq)*(q(ij,l,iq) 1039 : -0.5*(1.+sigw)*dzq(ij,l)) 1040 ENDIF 1041 ENDDO 1042 ENDDO 1043 c$OMP END DO NOWAIT 1044 !write(*,*) 'vlz 1001' 1045 1046 ELSE ! countcfl>=1 1047 1048 IF (prt_level>9) THEN 1049 WRITE(lunout,*)'vlz passage dans le non local' 1050 ENDIF 1051 c --------------------------------------------------------------- 1052 c Debut du traitement du cas ou on viole le CFL : w > masse 1053 c --------------------------------------------------------------- 1054 1055 c Initialisation 1056 1057 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 1058 DO l = 2,llm 1059 DO ij = ijb,ije 1060 wresi(ij,l)=w(ij,l,iq) 1061 wq(ij,l,iq)=0. 1062 IF(w(ij,l,iq).gt.0.) THEN 1063 lorig(ij,l)=l 1064 morig(ij,l)=masse(ij,l,iq) 1065 qorig(ij,l)=q(ij,l,iq) 1066 dzqorig(ij,l)=dzq(ij,l) 1067 ELSE 1068 lorig(ij,l)=l-1 1069 morig(ij,l)=masse(ij,l-1,iq) 1070 qorig(ij,l)=q(ij,l-1,iq) 1071 dzqorig(ij,l)=dzq(ij,l-1) 1072 ENDIF 1073 ENDDO 1074 ENDDO 1075 c$OMP END DO NOWAIT 1076 1077 c Reindicage vertical en accumulant les flux sur 1078 c les mailles qui viollent le CFL 1079 c on itère jusqu'à ce que tous les poins satisfassent 1080 c le critère 1081 DO WHILE (countcfl>=1) 1082 IF (prt_level>9) THEN 1083 WRITE(lunout,*)'On viole le CFL Vertical sur ',countcfl,' pts' 1084 ENDIF 1085 countcfl=0 1086 1087 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 1088 DO l = 2,llm 1089 DO ij = ijb,ije 1090 IF (ABS(wresi(ij,l))>morig(ij,l)) THEN 1091 countcfl=countcfl+1 1092 ! rm : les 8 lignes ci dessous pourraient sans doute s'ecrire 1093 ! avec la fonction sign 1094 IF(w(ij,l,iq)>0.) THEN 1095 wresi(ij,l)=wresi(ij,l)-morig(ij,l) 1096 wq(ij,l,iq)=wq(ij,l,iq)+morig(ij,l)*qorig(ij,l) 1097 lorig(ij,l)=lorig(ij,l)+1 1098 ELSE 1099 wresi(ij,l)=wresi(ij,l)+morig(ij,l) 1100 wq(ij,l,iq)=wq(ij,l,iq)-morig(ij,l)*qorig(ij,l) 1101 lorig(ij,l)=lorig(ij,l)-1 1102 ENDIF 1103 ! CRisi 24nov2020: ajout d'un message d'erreur clair au lieu d'un plantage 1104 ! pour seg fault 1105 if (lorig(ij,l).eq.0) then 1106 call abort_gcm("vlz in vlsplt_loc", 1107 : "unfixable violation of CFL",1) 1108 endif 1109 morig(ij,l)=masse(ij,lorig(ij,l),iq) 1110 qorig(ij,l)=q(ij,lorig(ij,l),iq) 1111 dzqorig(ij,l)=dzq(ij,lorig(ij,l)) 1112 ENDIF 1113 ENDDO 1114 ENDDO 1115 c$OMP END DO NOWAIT 1116 1117 ENDDO ! WHILE (countcfl>=1) 1118 1119 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 1120 DO l = 2,llm 1121 do ij = ijb,ije 1122 sigw=wresi(ij,l)/morig(ij,l) 1123 IF(w(ij,l,iq).gt.0.) THEN 1124 wq(ij,l,iq)=wq(ij,l,iq)+wresi(ij,l)*(qorig(ij,l) 1125 : +0.5*(1.-sigw)*dzqorig(ij,l)) 1126 ELSE 1127 wq(ij,l,iq)=wq(ij,l,iq)+wresi(ij,l)*(qorig(ij,l) 1128 : -0.5*(1.+sigw)*dzqorig(ij,l)) 1129 ENDIF 1130 ENDDO 1131 ENDDO 1132 c$OMP END DO NOWAIT 1133 1134 1135 ENDIF ! councfl=0 1136 1137 1138 1139 c$OMP MASTER 1140 DO ij=ijb,ije 1141 wq(ij,llm+1,iq)=0. 1142 wq(ij,1,iq)=0. 1143 ENDDO 1144 c$OMP END MASTER 1145 c$OMP BARRIER 1146 1147 ! CRisi: appel récursif de l'advection sur les fils. 1148 ! Il faut faire ça avant d'avoir mis à jour q et masse 1149 ! write(*,*)'vlsplt 942: iq,nqChildren(iq)=',iq,tracers(iq)%nqChildren 1150 do ifils=1,tracers(iq)%nqDescen 1151 iq2=tracers(iq)%iqDescen(ifils) 1152 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 1153 DO l=1,llm 1154 DO ij=ijb,ije 1155 !MVals: veiller a ce qu'on n'ait pas de denominateur nul 1156 masse(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass) 1157 if (q(ij,l,iq).gt.min_qParent) then 1158 Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq) 1159 else 1160 Ratio(ij,l,iq2)=min_ratio 1161 endif 1162 !wq(ij,l,iq2)=wq(ij,l,iq) ! correction bug le 15mai2015 1163 w(ij,l,iq2)=wq(ij,l,iq) 1164 enddo 1165 enddo 1166 c$OMP END DO NOWAIT 1167 enddo 1168 c$OMP BARRIER 1169 1170 do ifils=1,tracers(iq)%nqChildren 1171 iq2=tracers(iq)%iqDescen(ifils) 1172 call vlz_loc(Ratio,pente_max,masse,w,ijb_x,ije_x,iq2) 1173 enddo 1174 ! end CRisi 1175 1176 ! CRisi: On rajoute ici une barrière car on veut être sur que tous les 1177 ! wq soient synchronisés 1178 1179 c$OMP BARRIER 1180 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 1181 DO l=1,llm 1182 DO ij=ijb,ije 1183 newmasse=masse(ij,l,iq)+w(ij,l+1,iq)-w(ij,l,iq) 1184 q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq) 1185 & +wq(ij,l+1,iq)-wq(ij,l,iq)) 1186 & /newmasse 1187 masse(ij,l,iq)=newmasse 1188 ENDDO 1189 ENDDO 1190 c$OMP END DO NOWAIT 1191 1192 1193 ! retablir les fils en rapport de melange par rapport a l'air: 1194 do ifils=1,tracers(iq)%nqDescen 1195 iq2=tracers(iq)%iqDescen(ifils) 1196 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 1197 DO l=1,llm 1198 DO ij=ijb,ije 1199 q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2) 1200 enddo 1201 enddo 1202 c$OMP END DO NOWAIT 1203 enddo 1204 1205 RETURN 1206 END 1207 c SUBROUTINE minmaxq(zq,qmin,qmax,comment) 1208 c 1209 c INCLUDE "dimensions.h" 1210 c INCLUDE "paramet.h" 1211 1212 c CHARACTER*(*) comment 1213 c real qmin,qmax 1214 c real zq(ip1jmp1,llm) 1215 1216 c INTEGER jadrs(ip1jmp1), jbad, k, i 1217 1218 1219 c DO k = 1, llm 1220 c jbad = 0 1221 c DO i = 1, ip1jmp1 1222 c IF (zq(i,k).GT.qmax .OR. zq(i,k).LT.qmin) THEN 1223 c jbad = jbad + 1 1224 c jadrs(jbad) = i 1225 c ENDIF 1226 c ENDDO 1227 c IF (jbad.GT.0) THEN 1228 c PRINT*, comment 1229 c DO i = 1, jbad 1230 cc PRINT*, "i,k,zq=", jadrs(i),k,zq(jadrs(i),k) 1231 c ENDDO 1232 c ENDIF 1233 c ENDDO 1234 1235 c return 1236 c end 1237 1238 1239 1240 1201 enddo 1202 !$OMP END DO NOWAIT 1203 enddo 1204 1205 RETURN 1206 END SUBROUTINE vlz_loc 1207 ! SUBROUTINE minmaxq(zq,qmin,qmax,comment) 1208 ! 1209 ! INCLUDE "dimensions.h" 1210 ! INCLUDE "paramet.h" 1211 1212 ! CHARACTER*(*) comment 1213 ! real qmin,qmax 1214 ! real zq(ip1jmp1,llm) 1215 1216 ! INTEGER jadrs(ip1jmp1), jbad, k, i 1217 1218 1219 ! DO k = 1, llm 1220 ! jbad = 0 1221 ! DO i = 1, ip1jmp1 1222 ! IF (zq(i,k).GT.qmax .OR. zq(i,k).LT.qmin) THEN 1223 ! jbad = jbad + 1 1224 ! jadrs(jbad) = i 1225 ! ENDIF 1226 ! ENDDO 1227 ! IF (jbad.GT.0) THEN 1228 ! PRINT*, comment 1229 ! DO i = 1, jbad 1230 !c PRINT*, "i,k,zq=", jadrs(i),k,zq(jadrs(i),k) 1231 ! ENDDO 1232 ! ENDIF 1233 ! ENDDO 1234 1235 ! return 1236 ! end 1237 1238 1239 1240 -
LMDZ6/trunk/libf/phylmd/cosp/MISR_simulator.f90
r5247 r5248 1 ! 1 ! 2 2 ! Copyright (c) 2009, Roger Marchand, version 1.2 3 3 ! All rights reserved. 4 4 ! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $ 5 5 ! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/MISR_simulator/MISR_simulator.f $ 6 ! 7 ! Redistribution and use in source and binary forms, with or without modification, are permitted 6 ! 7 ! Redistribution and use in source and binary forms, with or without modification, are permitted 8 8 ! provided that the following conditions are met: 9 ! 10 ! * Redistributions of source code must retain the above copyright notice, this list of11 ! 12 ! * Redistributions in binary form must reproduce the above copyright notice, this list13 ! of conditions and the following disclaimer in the documentation and/or other materials14 ! 15 ! * Neither the name of the University of Washington nor the names of its contributors may be used16 ! 17 ! 9 ! 10 ! * Redistributions of source code must retain the above copyright notice, this list of 11 ! conditions and the following disclaimer. 12 ! * Redistributions in binary form must reproduce the above copyright notice, this list 13 ! of conditions and the following disclaimer in the documentation and/or other materials 14 ! provided with the distribution. 15 ! * Neither the name of the University of Washington nor the names of its contributors may be used 16 ! to endorse or promote products derived from this software without specific prior written permission. 17 ! 18 18 ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 19 ! BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT 20 ! SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 21 ! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 22 ! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 19 ! BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT 20 ! SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 21 ! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 22 ! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 23 23 ! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 24 24 ! 25 25 26 SUBROUTINE MISR_simulator( 27 & npoints, 28 & nlev, 29 & ncol, 30 & sunlit, 31 & zfull, 32 & at, 33 & dtau_s, 34 & dtau_c, 35 & frac_out, 36 & missing_value, 37 & fq_MISR_TAU_v_CTH, 38 & dist_model_layertops, 39 & MISR_mean_ztop, 40 & MISR_cldarea 41 & ) 42 43 44 implicit none 45 integer n_MISR_CTH 46 parameter(n_MISR_CTH=16) 47 48 ! ----- 49 ! Input 50 ! ----- 51 52 INTEGER npoints ! if ncol ==1, the number of model points in the horizontal grid 53 ! else the number of GCM grid points 54 55 INTEGER nlev ! number of model vertical levels 56 57 INTEGER ncol ! number of model sub columns 58 ! (must already be generated in via scops and passed to this 59 ! routine via the variable frac_out ) 60 61 INTEGER sunlit(npoints) ! 1 for day points, 0 for night time 62 63 REAL zfull(npoints,nlev) ! height (in meters) of full model levels (i.e. midpoints) 64 ! zfull(npoints,1) is top level of model 65 ! zfull(npoints,nlev) is bottom level of model (closest point to surface) 66 67 REAL at(npoints,nlev) ! temperature in each model level (K) 68 69 REAL dtau_s(npoints,nlev) ! visible wavelength cloud optical depth ... for "stratiform" condensate 70 ! NOTE: this the cloud optical depth of only the 71 ! the model cell (i,j) 72 73 REAL dtau_c(npoints,nlev) ! visible wavelength cloud optical depth ... for "convective" condensate 74 ! NOTE: this the cloud optical depth of only the 75 ! the model cell (i,j) 76 77 REAL frac_out(npoints,ncol,nlev) ! NOTE: only need if columns>1 ... subgrid scheme in use. 78 79 REAL missing_value 80 81 ! ------ 82 ! Outputs 83 ! ------ 84 85 REAL fq_MISR_TAU_v_CTH(npoints,7,n_MISR_CTH) 86 REAL dist_model_layertops(npoints,n_MISR_CTH) 87 REAL MISR_cldarea(npoints) ! fractional area coverged by clouds 88 REAL MISR_mean_ztop(npoints) ! mean cloud top hieght(m) MISR would observe 89 ! NOTE: == 0 if area ==0 90 91 92 ! ------ 93 ! Working variables 94 ! ------ 95 96 REAL tau(npoints,ncol) ! total column optical depth ... 97 98 INTEGER j,ilev,ilev2,ibox,k 99 INTEGER itau 100 101 LOGICAL box_cloudy(npoints,ncol) 102 103 real isccp_taumin 104 real boxarea 105 real tauchk 106 REAL box_MISR_ztop(npoints,ncol) ! cloud top hieght(m) MISR would observe 107 108 integer thres_crossed_MISR 109 integer loop,iMISR_ztop 110 111 real dtau, cloud_dtau, MISR_penetration_height,ztest 112 113 real MISR_CTH_boundaries(n_MISR_CTH+1) 114 115 DATA MISR_CTH_boundaries / -99, 0, 0.5, 1, 1.5, 2, 2.5, 3, 116 c 4, 5, 7, 9, 11, 13, 15, 17, 99 / 117 118 DATA isccp_taumin / 0.3 / 119 120 tauchk = -1.*log(0.9999999) 121 122 ! 123 ! For each GCM cell or horizontal model grid point ... 124 ! 125 do j=1,npoints 126 127 ! 128 ! estimate distribution of Model layer tops 129 ! 130 dist_model_layertops(j,:)=0 131 132 do ilev=1,nlev 133 134 ! define location of "layer top" 135 if(ilev.eq.1 .or. ilev.eq.nlev) then 136 ztest=zfull(j,ilev) 26 SUBROUTINE MISR_simulator( & 27 npoints, & 28 nlev, & 29 ncol, & 30 sunlit, & 31 zfull, & 32 at, & 33 dtau_s, & 34 dtau_c, & 35 frac_out, & 36 missing_value, & 37 fq_MISR_TAU_v_CTH, & 38 dist_model_layertops, & 39 MISR_mean_ztop, & 40 MISR_cldarea & 41 ) 42 43 44 implicit none 45 integer :: n_MISR_CTH 46 parameter(n_MISR_CTH=16) 47 48 ! ----- 49 ! Input 50 ! ----- 51 52 INTEGER :: npoints ! if ncol ==1, the number of model points in the horizontal grid 53 ! ! else the number of GCM grid points 54 55 INTEGER :: nlev ! number of model vertical levels 56 57 INTEGER :: ncol ! number of model sub columns 58 ! ! (must already be generated in via scops and passed to this 59 ! ! routine via the variable frac_out ) 60 61 INTEGER :: sunlit(npoints) ! 1 for day points, 0 for night time 62 63 REAL :: zfull(npoints,nlev) ! height (in meters) of full model levels (i.e. midpoints) 64 ! ! zfull(npoints,1) is top level of model 65 ! ! zfull(npoints,nlev) is bottom level of model (closest point to surface) 66 67 REAL :: at(npoints,nlev) ! temperature in each model level (K) 68 69 REAL :: dtau_s(npoints,nlev) ! visible wavelength cloud optical depth ... for "stratiform" condensate 70 ! ! NOTE: this the cloud optical depth of only the 71 ! ! the model cell (i,j) 72 73 REAL :: dtau_c(npoints,nlev) ! visible wavelength cloud optical depth ... for "convective" condensate 74 ! ! NOTE: this the cloud optical depth of only the 75 ! ! the model cell (i,j) 76 77 REAL :: frac_out(npoints,ncol,nlev) ! NOTE: only need if columns>1 ... subgrid scheme in use. 78 79 REAL :: missing_value 80 81 ! ------ 82 ! Outputs 83 ! ------ 84 85 REAL :: fq_MISR_TAU_v_CTH(npoints,7,n_MISR_CTH) 86 REAL :: dist_model_layertops(npoints,n_MISR_CTH) 87 REAL :: MISR_cldarea(npoints) ! fractional area coverged by clouds 88 REAL :: MISR_mean_ztop(npoints) ! mean cloud top hieght(m) MISR would observe 89 ! ! NOTE: == 0 if area ==0 90 91 92 ! ------ 93 ! Working variables 94 ! ------ 95 96 REAL :: tau(npoints,ncol) ! total column optical depth ... 97 98 INTEGER :: j,ilev,ilev2,ibox,k 99 INTEGER :: itau 100 101 LOGICAL :: box_cloudy(npoints,ncol) 102 103 real :: isccp_taumin 104 real :: boxarea 105 real :: tauchk 106 REAL :: box_MISR_ztop(npoints,ncol) ! cloud top hieght(m) MISR would observe 107 108 integer :: thres_crossed_MISR 109 integer :: loop,iMISR_ztop 110 111 real :: dtau, cloud_dtau, MISR_penetration_height,ztest 112 113 real :: MISR_CTH_boundaries(n_MISR_CTH+1) 114 115 DATA MISR_CTH_boundaries / -99, 0, 0.5, 1, 1.5, 2, 2.5, 3, & 116 4, 5, 7, 9, 11, 13, 15, 17, 99 / 117 118 DATA isccp_taumin / 0.3 / 119 120 tauchk = -1.*log(0.9999999) 121 122 ! ! 123 ! ! For each GCM cell or horizontal model grid point ... 124 ! ! 125 do j=1,npoints 126 127 ! ! 128 ! ! estimate distribution of Model layer tops 129 ! ! 130 dist_model_layertops(j,:)=0 131 132 do ilev=1,nlev 133 134 ! ! define location of "layer top" 135 if(ilev.eq.1 .or. ilev.eq.nlev) then 136 ztest=zfull(j,ilev) 137 else 138 ztest=0.5*(zfull(j,ilev)+zfull(j,ilev-1)) 139 endif 140 141 ! ! find MISR layer that contains this level 142 ! ! note, the first MISR level is "no height" level 143 iMISR_ztop=2 144 do loop=2,n_MISR_CTH 145 146 if ( ztest .gt. & 147 1000*MISR_CTH_boundaries(loop+1) ) then 148 149 iMISR_ztop=loop+1 150 endif 151 enddo 152 153 dist_model_layertops(j,iMISR_ztop)= & 154 dist_model_layertops(j,iMISR_ztop)+1 155 enddo 156 157 158 ! ! 159 ! ! compute total cloud optical depth for each column 160 ! ! 161 do ibox=1,ncol 162 163 ! ! Initialize tau to zero in each subcolum 164 tau(j,ibox)=0. 165 box_cloudy(j,ibox)=.false. 166 box_MISR_ztop(j,ibox)=0 167 168 ! ! initialize threshold detection for each sub column 169 thres_crossed_MISR=0; 170 171 do ilev=1,nlev 172 173 dtau=0 174 175 if (frac_out(j,ibox,ilev).eq.1) then 176 dtau = dtau_s(j,ilev) 177 endif 178 179 if (frac_out(j,ibox,ilev).eq.2) then 180 dtau = dtau_c(j,ilev) 181 end if 182 183 tau(j,ibox)=tau(j,ibox)+ dtau 184 185 186 ! ! NOW for MISR .. 187 ! ! if there a cloud ... start the counter ... store this height 188 if(thres_crossed_MISR .eq. 0 .and. dtau .gt. 0.) then 189 190 ! ! first encountered a "cloud" 191 thres_crossed_MISR=1 192 cloud_dtau=0 193 endif 194 195 if( thres_crossed_MISR .lt. 99 .and. & 196 thres_crossed_MISR .gt. 0 ) then 197 198 if( dtau .eq. 0.) then 199 200 ! ! we have come to the end of the current cloud 201 ! ! layer without yet selecting a CTH boundary. 202 ! ! ... restart cloud tau counter 203 cloud_dtau=0 137 204 else 138 ztest=0.5*(zfull(j,ilev)+zfull(j,ilev-1)) 139 endif 140 141 ! find MISR layer that contains this level 142 ! note, the first MISR level is "no height" level 205 ! ! add current optical depth to count for 206 ! ! the current cloud layer 207 cloud_dtau=cloud_dtau+dtau 208 endif 209 210 ! ! if the cloud is continuous but optically thin (< 1) 211 ! ! from above the current layer cloud top to the current level 212 ! ! then MISR will like see a top below the top of the current 213 ! ! layer 214 if( dtau.gt.0 .and. (cloud_dtau-dtau) .lt. 1) then 215 216 if(dtau .lt. 1 .or. ilev.eq.1 .or. ilev.eq.nlev) then 217 218 ! ! MISR will likely penetrate to some point 219 ! ! within this layer ... the middle 220 MISR_penetration_height=zfull(j,ilev) 221 222 else 223 ! ! take the OD = 1.0 level into this layer 224 MISR_penetration_height= & 225 0.5*(zfull(j,ilev)+zfull(j,ilev-1)) - & 226 0.5*(zfull(j,ilev-1)-zfull(j,ilev+1)) & 227 /dtau 228 endif 229 230 box_MISR_ztop(j,ibox)=MISR_penetration_height 231 232 endif 233 234 ! ! check for a distinctive water layer 235 if(dtau .gt. 1 .and. at(j,ilev).gt.273 ) then 236 237 ! ! must be a water cloud ... 238 ! ! take this as CTH level 239 thres_crossed_MISR=99 240 endif 241 242 ! ! if the total column optical depth is "large" than 243 ! ! MISR can't seen anything else ... set current point as CTH level 244 if(tau(j,ibox) .gt. 5) then 245 246 thres_crossed_MISR=99 247 endif 248 249 endif ! MISR CTH booundary not set 250 251 enddo !ilev - loop over vertical levesl 252 253 ! ! written by roj 5/2006 254 ! ! check to see if there was a cloud for which we didn't 255 ! ! set a MISR cloud top boundary 256 if( thres_crossed_MISR .eq. 1) then 257 258 ! ! if the cloud has a total optical depth of greater 259 ! ! than ~ 0.5 MISR will still likely pick up this cloud 260 ! ! with a height near the true cloud top 261 ! ! otherwise there should be no CTH 262 if( tau(j,ibox) .gt. 0.5) then 263 264 ! ! keep MISR detected CTH 265 266 elseif(tau(j,ibox) .gt. 0.2) then 267 268 ! ! MISR may detect but wont likley have a good height 269 box_MISR_ztop(j,ibox)=-1 270 271 else 272 ! ! MISR not likely to even detect. 273 ! ! so set as not cloudy 274 box_MISR_ztop(j,ibox)=0 275 276 endif 277 278 endif 279 280 enddo ! loop of subcolumns 281 enddo ! loop of gridpoints 282 283 284 ! ! 285 ! ! Modify MISR CTH for satellite spatial / pattern matcher effects 286 ! ! 287 ! ! Code in this region added by roj 5/2006 to account 288 ! ! for spatial effect of the MISR pattern matcher. 289 ! ! Basically, if a column is found between two neighbors 290 ! ! at the same CTH, and that column has no hieght or 291 ! ! a lower CTH, THEN misr will tend to but place the 292 ! ! odd column at the same height as it neighbors. 293 ! ! 294 ! ! This setup assumes the columns represent a about a 1 to 4 km scale 295 ! ! it will need to be modified significantly, otherwise 296 if(ncol.eq.1) then 297 298 ! ! adjust based on neightboring points ... i.e. only 2D grid was input 299 do j=2,npoints-1 300 301 if(box_MISR_ztop(j-1,1).gt.0 .and. & 302 box_MISR_ztop(j+1,1).gt.0 ) then 303 304 if( abs( box_MISR_ztop(j-1,1) - & 305 box_MISR_ztop(j+1,1) ) .lt. 500 & 306 .and. & 307 box_MISR_ztop(j,1) .lt. & 308 box_MISR_ztop(j+1,1) ) then 309 310 box_MISR_ztop(j,1) = & 311 box_MISR_ztop(j+1,1) 312 endif 313 314 endif 315 enddo 316 else 317 318 ! ! adjust based on neighboring subcolumns .... 319 do ibox=2,ncol-1 320 321 if(box_MISR_ztop(1,ibox-1).gt.0 .and. & 322 box_MISR_ztop(1,ibox+1).gt.0 ) then 323 324 if( abs( box_MISR_ztop(1,ibox-1) - & 325 box_MISR_ztop(1,ibox+1) ) .lt. 500 & 326 .and. & 327 box_MISR_ztop(1,ibox) .lt. & 328 box_MISR_ztop(1,ibox+1) ) then 329 330 box_MISR_ztop(1,ibox) = & 331 box_MISR_ztop(1,ibox+1) 332 endif 333 334 endif 335 enddo 336 337 endif 338 339 ! ! 340 ! ! DETERMINE CLOUD TYPE FREQUENCIES 341 ! ! 342 ! ! Now that ztop and tau have been determined, 343 ! ! determine amount of each cloud type 344 boxarea=1./real(ncol) 345 do j=1,npoints 346 347 ! ! reset frequencies -- modified loop structure, roj 5/2006 348 do ilev=1,7 ! "tau loop" 349 do ilev2=1,n_MISR_CTH 350 fq_MISR_TAU_v_CTH(j,ilev,ilev2)=0. 351 enddo 352 enddo 353 354 MISR_cldarea(j)=0. 355 MISR_mean_ztop(j)=0. 356 357 do ibox=1,ncol 358 359 if (tau(j,ibox) .gt. (tauchk)) then 360 box_cloudy(j,ibox)=.true. 361 endif 362 363 itau = 0 364 365 if (box_cloudy(j,ibox)) then 366 367 ! !determine optical depth category 368 if (tau(j,ibox) .lt. isccp_taumin) then 369 itau=1 370 else if (tau(j,ibox) .ge. isccp_taumin & 371 .and. tau(j,ibox) .lt. 1.3) then 372 itau=2 373 else if (tau(j,ibox) .ge. 1.3 & 374 .and. tau(j,ibox) .lt. 3.6) then 375 itau=3 376 else if (tau(j,ibox) .ge. 3.6 & 377 .and. tau(j,ibox) .lt. 9.4) then 378 itau=4 379 else if (tau(j,ibox) .ge. 9.4 & 380 .and. tau(j,ibox) .lt. 23.) then 381 itau=5 382 else if (tau(j,ibox) .ge. 23. & 383 .and. tau(j,ibox) .lt. 60.) then 384 itau=6 385 else if (tau(j,ibox) .ge. 60.) then 386 itau=7 387 endif 388 389 endif 390 391 ! ! update MISR histograms and summary metrics - roj 5/2005 392 if (sunlit(j).eq.1) then 393 394 ! !if cloudy added by roj 5/2005 395 if( box_MISR_ztop(j,ibox).eq.0) then 396 397 ! ! no cloud detected 398 iMISR_ztop=0 399 400 elseif( box_MISR_ztop(j,ibox).eq.-1) then 401 402 ! ! cloud can be detected but too thin to get CTH 403 iMISR_ztop=1 404 405 fq_MISR_TAU_v_CTH(j,itau,iMISR_ztop)= & 406 fq_MISR_TAU_v_CTH(j,itau,iMISR_ztop) + boxarea 407 408 else 409 410 ! ! 411 ! ! determine index for MISR bin set 412 ! ! 413 143 414 iMISR_ztop=2 415 144 416 do loop=2,n_MISR_CTH 145 146 if ( ztest .gt. 147 & 1000*MISR_CTH_boundaries(loop+1) ) then 148 149 iMISR_ztop=loop+1 417 418 if ( box_MISR_ztop(j,ibox) .gt. & 419 1000*MISR_CTH_boundaries(loop+1) ) then 420 421 iMISR_ztop=loop+1 422 150 423 endif 151 424 enddo 152 425 153 dist_model_layertops(j,iMISR_ztop)= 154 & dist_model_layertops(j,iMISR_ztop)+1 155 enddo 156 157 158 ! 159 ! compute total cloud optical depth for each column 160 ! 161 do ibox=1,ncol 162 163 ! Initialize tau to zero in each subcolum 164 tau(j,ibox)=0. 165 box_cloudy(j,ibox)=.false. 166 box_MISR_ztop(j,ibox)=0 167 168 ! initialize threshold detection for each sub column 169 thres_crossed_MISR=0; 170 171 do ilev=1,nlev 172 173 dtau=0 174 175 if (frac_out(j,ibox,ilev).eq.1) then 176 dtau = dtau_s(j,ilev) 177 endif 178 179 if (frac_out(j,ibox,ilev).eq.2) then 180 dtau = dtau_c(j,ilev) 181 end if 182 183 tau(j,ibox)=tau(j,ibox)+ dtau 184 185 186 ! NOW for MISR .. 187 ! if there a cloud ... start the counter ... store this height 188 if(thres_crossed_MISR .eq. 0 .and. dtau .gt. 0.) then 189 190 ! first encountered a "cloud" 191 thres_crossed_MISR=1 192 cloud_dtau=0 193 endif 194 195 if( thres_crossed_MISR .lt. 99 .and. 196 & thres_crossed_MISR .gt. 0 ) then 197 198 if( dtau .eq. 0.) then 199 200 ! we have come to the end of the current cloud 201 ! layer without yet selecting a CTH boundary. 202 ! ... restart cloud tau counter 203 cloud_dtau=0 204 else 205 ! add current optical depth to count for 206 ! the current cloud layer 207 cloud_dtau=cloud_dtau+dtau 208 endif 209 210 ! if the cloud is continuous but optically thin (< 1) 211 ! from above the current layer cloud top to the current level 212 ! then MISR will like see a top below the top of the current 213 ! layer 214 if( dtau.gt.0 .and. (cloud_dtau-dtau) .lt. 1) then 215 216 if(dtau .lt. 1 .or. ilev.eq.1 .or. ilev.eq.nlev) then 217 218 ! MISR will likely penetrate to some point 219 ! within this layer ... the middle 220 MISR_penetration_height=zfull(j,ilev) 221 222 else 223 ! take the OD = 1.0 level into this layer 224 MISR_penetration_height= 225 & 0.5*(zfull(j,ilev)+zfull(j,ilev-1)) - 226 & 0.5*(zfull(j,ilev-1)-zfull(j,ilev+1)) 227 & /dtau 228 endif 229 230 box_MISR_ztop(j,ibox)=MISR_penetration_height 231 232 endif 233 234 ! check for a distinctive water layer 235 if(dtau .gt. 1 .and. at(j,ilev).gt.273 ) then 236 237 ! must be a water cloud ... 238 ! take this as CTH level 239 thres_crossed_MISR=99 240 endif 241 242 ! if the total column optical depth is "large" than 243 ! MISR can't seen anything else ... set current point as CTH level 244 if(tau(j,ibox) .gt. 5) then 245 246 thres_crossed_MISR=99 247 endif 248 249 endif ! MISR CTH booundary not set 250 251 enddo !ilev - loop over vertical levesl 252 253 ! written by roj 5/2006 254 ! check to see if there was a cloud for which we didn't 255 ! set a MISR cloud top boundary 256 if( thres_crossed_MISR .eq. 1) then 257 258 ! if the cloud has a total optical depth of greater 259 ! than ~ 0.5 MISR will still likely pick up this cloud 260 ! with a height near the true cloud top 261 ! otherwise there should be no CTH 262 if( tau(j,ibox) .gt. 0.5) then 263 264 ! keep MISR detected CTH 265 266 elseif(tau(j,ibox) .gt. 0.2) then 267 268 ! MISR may detect but wont likley have a good height 269 box_MISR_ztop(j,ibox)=-1 270 426 if(box_cloudy(j,ibox)) then 427 428 ! ! there is an isccp clouds so itau(j) is defined 429 fq_MISR_TAU_v_CTH(j,itau,iMISR_ztop)= & 430 fq_MISR_TAU_v_CTH(j,itau,iMISR_ztop) + boxarea 431 271 432 else 272 ! MISR not likely to even detect. 273 ! so set as not cloudy 274 box_MISR_ztop(j,ibox)=0 275 276 endif 277 278 endif 279 280 enddo ! loop of subcolumns 281 enddo ! loop of gridpoints 282 283 284 ! 285 ! Modify MISR CTH for satellite spatial / pattern matcher effects 286 ! 287 ! Code in this region added by roj 5/2006 to account 288 ! for spatial effect of the MISR pattern matcher. 289 ! Basically, if a column is found between two neighbors 290 ! at the same CTH, and that column has no hieght or 291 ! a lower CTH, THEN misr will tend to but place the 292 ! odd column at the same height as it neighbors. 293 ! 294 ! This setup assumes the columns represent a about a 1 to 4 km scale 295 ! it will need to be modified significantly, otherwise 296 if(ncol.eq.1) then 297 298 ! adjust based on neightboring points ... i.e. only 2D grid was input 299 do j=2,npoints-1 300 301 if(box_MISR_ztop(j-1,1).gt.0 .and. 302 & box_MISR_ztop(j+1,1).gt.0 ) then 303 304 if( abs( box_MISR_ztop(j-1,1) - 305 & box_MISR_ztop(j+1,1) ) .lt. 500 306 & .and. 307 & box_MISR_ztop(j,1) .lt. 308 & box_MISR_ztop(j+1,1) ) then 309 310 box_MISR_ztop(j,1) = 311 & box_MISR_ztop(j+1,1) 312 endif 313 314 endif 433 ! ! MISR CTH resolution is trying to fill in a 434 ! ! broken cloud scene where there is no condensate. 435 ! ! The MISR CTH-1D-OD product will only put in a cloud 436 ! ! if the MISR cloud mask indicates cloud. 437 ! ! therefore we will not include this column in the histogram 438 ! ! in reality aerosoal and 3D effects or bright surfaces 439 ! ! could fool the MISR cloud mask 440 441 ! ! the alternative is to count as very thin cloud ?? 442 ! fq_MISR_TAU_v_CTH(1,iMISR_ztop)= 443 ! & fq_MISR_TAU_v_CTH(1,iMISR_ztop) + boxarea 444 endif 445 446 447 MISR_mean_ztop(j)=MISR_mean_ztop(j)+ & 448 box_MISR_ztop(j,ibox)*boxarea 449 450 MISR_cldarea(j)=MISR_cldarea(j) + boxarea 451 452 endif 453 else 454 ! ! Set to issing data. A. Bodas - 14/05/2010 455 do loop=1,n_MISR_CTH 456 do k=1,7 457 fq_MISR_TAU_v_CTH(j,k,loop) = missing_value 315 458 enddo 316 else 317 318 ! adjust based on neighboring subcolumns .... 319 do ibox=2,ncol-1 320 321 if(box_MISR_ztop(1,ibox-1).gt.0 .and. 322 & box_MISR_ztop(1,ibox+1).gt.0 ) then 323 324 if( abs( box_MISR_ztop(1,ibox-1) - 325 & box_MISR_ztop(1,ibox+1) ) .lt. 500 326 & .and. 327 & box_MISR_ztop(1,ibox) .lt. 328 & box_MISR_ztop(1,ibox+1) ) then 329 330 box_MISR_ztop(1,ibox) = 331 & box_MISR_ztop(1,ibox+1) 332 endif 333 334 endif 335 enddo 336 337 endif 338 339 ! 340 ! DETERMINE CLOUD TYPE FREQUENCIES 341 ! 342 ! Now that ztop and tau have been determined, 343 ! determine amount of each cloud type 344 boxarea=1./real(ncol) 345 do j=1,npoints 346 347 ! reset frequencies -- modified loop structure, roj 5/2006 348 do ilev=1,7 ! "tau loop" 349 do ilev2=1,n_MISR_CTH 350 fq_MISR_TAU_v_CTH(j,ilev,ilev2)=0. 351 enddo 352 enddo 353 354 MISR_cldarea(j)=0. 355 MISR_mean_ztop(j)=0. 356 357 do ibox=1,ncol 358 359 if (tau(j,ibox) .gt. (tauchk)) then 360 box_cloudy(j,ibox)=.true. 361 endif 362 363 itau = 0 364 365 if (box_cloudy(j,ibox)) then 366 367 !determine optical depth category 368 if (tau(j,ibox) .lt. isccp_taumin) then 369 itau=1 370 else if (tau(j,ibox) .ge. isccp_taumin 371 & .and. tau(j,ibox) .lt. 1.3) then 372 itau=2 373 else if (tau(j,ibox) .ge. 1.3 374 & .and. tau(j,ibox) .lt. 3.6) then 375 itau=3 376 else if (tau(j,ibox) .ge. 3.6 377 & .and. tau(j,ibox) .lt. 9.4) then 378 itau=4 379 else if (tau(j,ibox) .ge. 9.4 380 & .and. tau(j,ibox) .lt. 23.) then 381 itau=5 382 else if (tau(j,ibox) .ge. 23. 383 & .and. tau(j,ibox) .lt. 60.) then 384 itau=6 385 else if (tau(j,ibox) .ge. 60.) then 386 itau=7 387 endif 388 389 endif 390 391 ! update MISR histograms and summary metrics - roj 5/2005 392 if (sunlit(j).eq.1) then 393 394 !if cloudy added by roj 5/2005 395 if( box_MISR_ztop(j,ibox).eq.0) then 396 397 ! no cloud detected 398 iMISR_ztop=0 399 400 elseif( box_MISR_ztop(j,ibox).eq.-1) then 401 402 ! cloud can be detected but too thin to get CTH 403 iMISR_ztop=1 404 405 fq_MISR_TAU_v_CTH(j,itau,iMISR_ztop)= 406 & fq_MISR_TAU_v_CTH(j,itau,iMISR_ztop) + boxarea 407 408 else 409 410 ! 411 ! determine index for MISR bin set 412 ! 413 414 iMISR_ztop=2 415 416 do loop=2,n_MISR_CTH 417 418 if ( box_MISR_ztop(j,ibox) .gt. 419 & 1000*MISR_CTH_boundaries(loop+1) ) then 420 421 iMISR_ztop=loop+1 422 423 endif 424 enddo 425 426 if(box_cloudy(j,ibox)) then 427 428 ! there is an isccp clouds so itau(j) is defined 429 fq_MISR_TAU_v_CTH(j,itau,iMISR_ztop)= 430 & fq_MISR_TAU_v_CTH(j,itau,iMISR_ztop) + boxarea 431 432 else 433 ! MISR CTH resolution is trying to fill in a 434 ! broken cloud scene where there is no condensate. 435 ! The MISR CTH-1D-OD product will only put in a cloud 436 ! if the MISR cloud mask indicates cloud. 437 ! therefore we will not include this column in the histogram 438 ! in reality aerosoal and 3D effects or bright surfaces 439 ! could fool the MISR cloud mask 440 441 ! the alternative is to count as very thin cloud ?? 442 ! fq_MISR_TAU_v_CTH(1,iMISR_ztop)= 443 ! & fq_MISR_TAU_v_CTH(1,iMISR_ztop) + boxarea 444 endif 445 446 447 MISR_mean_ztop(j)=MISR_mean_ztop(j)+ 448 & box_MISR_ztop(j,ibox)*boxarea 449 450 MISR_cldarea(j)=MISR_cldarea(j) + boxarea 451 452 endif 453 else 454 ! Set to issing data. A. Bodas - 14/05/2010 455 do loop=1,n_MISR_CTH 456 do k=1,7 457 fq_MISR_TAU_v_CTH(j,k,loop) = missing_value 458 enddo 459 dist_model_layertops(j,loop) = missing_value 460 enddo 461 MISR_cldarea(j) = missing_value 462 MISR_mean_ztop(npoints) = missing_value 463 464 endif ! is sunlight ? 465 466 enddo ! ibox - loop over subcolumns 467 468 if( MISR_cldarea(j) .gt. 0.) then 469 MISR_mean_ztop(j)= MISR_mean_ztop(j) / MISR_cldarea(j) ! roj 5/2006 470 endif 471 472 enddo ! loop over grid points 473 474 return 475 end 459 dist_model_layertops(j,loop) = missing_value 460 enddo 461 MISR_cldarea(j) = missing_value 462 MISR_mean_ztop(npoints) = missing_value 463 464 endif ! is sunlight ? 465 466 enddo ! ibox - loop over subcolumns 467 468 if( MISR_cldarea(j) .gt. 0.) then 469 MISR_mean_ztop(j)= MISR_mean_ztop(j) / MISR_cldarea(j) ! roj 5/2006 470 endif 471 472 enddo ! loop over grid points 473 474 return 475 end subroutine misr_simulator -
LMDZ6/trunk/libf/phylmd/cosp/icarus.f90
r5247 r5248 1 1 ! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $ 2 2 ! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/icarus-scops-4.1-bsd/icarus.f $ 3 SUBROUTINE ICARUS( 4 & debug, 5 & debugcol, 6 & npoints, 7 & sunlit, 8 & nlev, 9 & ncol, 10 & pfull, 11 & phalf, 12 & qv, 13 & cc, 14 & conv, 15 & dtau_s, 16 & dtau_c, 17 & top_height, 18 & top_height_direction, 19 & overlap, 20 & frac_out, 21 & skt, 22 & emsfc_lw, 23 & at, 24 & dem_s, 25 & dem_c, 26 & fq_isccp, 27 & totalcldarea, 28 & meanptop, 29 & meantaucld, 30 & meanalbedocld, 31 & meantb, 32 & meantbclr, 33 & boxtau, 34 & boxptop 35 &) 36 37 !$Id: icarus.f,v 4.1 2010/05/27 16:30:18 hadmw Exp $ 38 39 ! *****************************COPYRIGHT**************************** 40 ! (c) 2009, Lawrence Livermore National Security Limited Liability 41 ! Corporation. 42 ! All rights reserved. 43 ! 44 ! Redistribution and use in source and binary forms, with or without 45 ! modification, are permitted provided that the 46 ! following conditions are met: 47 ! 48 ! * Redistributions of source code must retain the above 49 ! copyright notice, this list of conditions and the following 50 ! disclaimer. 51 ! * Redistributions in binary form must reproduce the above 52 ! copyright notice, this list of conditions and the following 53 ! disclaimer in the documentation and/or other materials 54 ! provided with the distribution. 55 ! * Neither the name of the Lawrence Livermore National Security 56 ! Limited Liability Corporation nor the names of its 57 ! contributors may be used to endorse or promote products 58 ! derived from this software without specific prior written 59 ! permission. 60 ! 61 ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 62 ! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 63 ! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 64 ! A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 65 ! OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 66 ! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 67 ! LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 68 ! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 69 ! THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 70 ! (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 71 ! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 72 ! 73 ! *****************************COPYRIGHT******************************* 74 ! *****************************COPYRIGHT******************************* 75 ! *****************************COPYRIGHT******************************* 76 ! *****************************COPYRIGHT******************************* 77 78 implicit none 79 80 ! NOTE: the maximum number of levels and columns is set by 81 ! the following parameter statement 82 83 INTEGER ncolprint 84 85 ! ----- 86 ! Input 87 ! ----- 88 89 INTEGER npoints ! number of model points in the horizontal 90 INTEGER nlev ! number of model levels in column 91 INTEGER ncol ! number of subcolumns 92 93 INTEGER sunlit(npoints) ! 1 for day points, 0 for night time 94 95 REAL pfull(npoints,nlev) 96 ! pressure of full model levels (Pascals) 97 ! pfull(npoints,1) is top level of model 98 ! pfull(npoints,nlev) is bot of model 99 100 REAL phalf(npoints,nlev+1) 101 ! pressure of half model levels (Pascals) 102 ! phalf(npoints,1) is top of model 103 ! phalf(npoints,nlev+1) is the surface pressure 104 105 REAL qv(npoints,nlev) 106 ! water vapor specific humidity (kg vapor/ kg air) 107 ! on full model levels 108 109 REAL cc(npoints,nlev) 110 ! input cloud cover in each model level (fraction) 111 ! NOTE: This is the HORIZONTAL area of each 112 ! grid box covered by clouds 113 114 REAL conv(npoints,nlev) 115 ! input convective cloud cover in each model 116 ! level (fraction) 117 ! NOTE: This is the HORIZONTAL area of each 118 ! grid box covered by convective clouds 119 120 REAL dtau_s(npoints,nlev) 121 ! mean 0.67 micron optical depth of stratiform 122 ! clouds in each model level 123 ! NOTE: this the cloud optical depth of only the 124 ! cloudy part of the grid box, it is not weighted 125 ! with the 0 cloud optical depth of the clear 126 ! part of the grid box 127 128 REAL dtau_c(npoints,nlev) 129 ! mean 0.67 micron optical depth of convective 130 ! clouds in each 131 ! model level. Same note applies as in dtau_s. 132 133 INTEGER overlap ! overlap type 134 ! 1=max 135 ! 2=rand 136 ! 3=max/rand 137 138 INTEGER top_height ! 1 = adjust top height using both a computed 139 ! infrared brightness temperature and the visible 140 ! optical depth to adjust cloud top pressure. Note 141 ! that this calculation is most appropriate to compare 142 ! to ISCCP data during sunlit hours. 143 ! 2 = do not adjust top height, that is cloud top 144 ! pressure is the actual cloud top pressure 145 ! in the model 146 ! 3 = adjust top height using only the computed 147 ! infrared brightness temperature. Note that this 148 ! calculation is most appropriate to compare to ISCCP 149 ! IR only algortihm (i.e. you can compare to nighttime 150 ! ISCCP data with this option) 151 152 INTEGER top_height_direction ! direction for finding atmosphere pressure level 153 ! with interpolated temperature equal to the radiance 154 ! determined cloud-top temperature 155 ! 156 ! 1 = find the *lowest* altitude (highest pressure) level 157 ! with interpolated temperature equal to the radiance 158 ! determined cloud-top temperature 159 ! 160 ! 2 = find the *highest* altitude (lowest pressure) level 161 ! with interpolated temperature equal to the radiance 162 ! determined cloud-top temperature 163 ! 164 ! ONLY APPLICABLE IF top_height EQUALS 1 or 3 165 ! ! 166 ! 1 = old setting: matches all versions of 167 ! ISCCP simulator with versions numbers 3.5.1 and lower 168 ! 169 ! 2 = default setting: for version numbers 4.0 and higher 170 ! 171 ! The following input variables are used only if top_height = 1 or top_height = 3 172 ! 173 REAL skt(npoints) ! skin Temperature (K) 174 REAL emsfc_lw ! 10.5 micron emissivity of surface (fraction) 175 REAL at(npoints,nlev) ! temperature in each model level (K) 176 REAL dem_s(npoints,nlev) ! 10.5 micron longwave emissivity of stratiform 177 ! clouds in each 178 ! model level. Same note applies as in dtau_s. 179 REAL dem_c(npoints,nlev) ! 10.5 micron longwave emissivity of convective 180 ! clouds in each 181 ! model level. Same note applies as in dtau_s. 182 183 REAL frac_out(npoints,ncol,nlev) ! boxes gridbox divided up into 184 ! Equivalent of BOX in original version, but 185 ! indexed by column then row, rather than 186 ! by row then column 187 188 189 190 ! ------ 191 ! Output 192 ! ------ 193 194 REAL fq_isccp(npoints,7,7) ! the fraction of the model grid box covered by 195 ! each of the 49 ISCCP D level cloud types 196 197 REAL totalcldarea(npoints) ! the fraction of model grid box columns 198 ! with cloud somewhere in them. NOTE: This diagnostic 199 ! does not count model clouds with tau < isccp_taumin 200 ! Thus this diagnostic does not equal the sum over all entries of fq_isccp. 201 ! However, this diagnostic does equal the sum over entries of fq_isccp with 202 ! itau = 2:7 (omitting itau = 1) 203 204 205 ! The following three means are averages only over the cloudy areas with tau > isccp_taumin. 206 ! If no clouds with tau > isccp_taumin are in grid box all three quantities should equal zero. 207 208 REAL meanptop(npoints) ! mean cloud top pressure (mb) - linear averaging 209 ! in cloud top pressure. 210 211 REAL meantaucld(npoints) ! mean optical thickness 212 ! linear averaging in albedo performed. 213 214 real meanalbedocld(npoints) ! mean cloud albedo 215 ! linear averaging in albedo performed 216 217 real meantb(npoints) ! mean all-sky 10.5 micron brightness temperature 218 219 real meantbclr(npoints) ! mean clear-sky 10.5 micron brightness temperature 220 221 REAL boxtau(npoints,ncol) ! optical thickness in each column 222 223 REAL boxptop(npoints,ncol) ! cloud top pressure (mb) in each column 224 225 226 ! 227 ! ------ 228 ! Working variables added when program updated to mimic Mark Webb's PV-Wave code 229 ! ------ 230 231 REAL dem(npoints,ncol),bb(npoints) ! working variables for 10.5 micron longwave 232 ! emissivity in part of 233 ! gridbox under consideration 234 235 REAL ptrop(npoints) 236 REAL attrop(npoints) 237 REAL attropmin (npoints) 238 REAL atmax(npoints) 239 REAL btcmin(npoints) 240 REAL transmax(npoints) 241 242 INTEGER i,j,ilev,ibox,itrop(npoints) 243 INTEGER ipres(npoints) 244 INTEGER itau(npoints),ilev2 245 INTEGER acc(nlev,ncol) 246 INTEGER match(npoints,nlev-1) 247 INTEGER nmatch(npoints) 248 INTEGER levmatch(npoints,ncol) 249 250 !variables needed for water vapor continuum absorption 251 real fluxtop_clrsky(npoints),trans_layers_above_clrsky(npoints) 252 real taumin(npoints) 253 real dem_wv(npoints,nlev), wtmair, wtmh20, Navo, grav, pstd, t0 254 real press(npoints), dpress(npoints), atmden(npoints) 255 real rvh20(npoints), wk(npoints), rhoave(npoints) 256 real rh20s(npoints), rfrgn(npoints) 257 real tmpexp(npoints),tauwv(npoints) 258 259 character*1 cchar(6),cchar_realtops(6) 260 integer icycle 261 REAL tau(npoints,ncol) 262 LOGICAL box_cloudy(npoints,ncol) 263 REAL tb(npoints,ncol) 264 REAL ptop(npoints,ncol) 265 REAL emcld(npoints,ncol) 266 REAL fluxtop(npoints,ncol) 267 REAL trans_layers_above(npoints,ncol) 268 real isccp_taumin,fluxtopinit(npoints),tauir(npoints) 269 REAL albedocld(npoints,ncol) 270 real boxarea 271 integer debug ! set to non-zero value to print out inputs 272 ! with step debug 273 integer debugcol ! set to non-zero value to print out column 274 ! decomposition with step debugcol 275 integer rangevec(npoints),rangeerror 276 277 integer index1(npoints),num1,jj,k1,k2 278 real rec2p13,tauchk,logp,logp1,logp2,atd 279 real output_missing_value 280 281 character*10 ftn09 282 283 DATA isccp_taumin / 0.3 / 284 DATA output_missing_value / -1.E+30 / 285 DATA cchar / ' ','-','1','+','I','+'/ 286 DATA cchar_realtops / ' ',' ','1','1','I','I'/ 287 288 ! ------ End duplicate definitions common to wrapper routine 289 290 tauchk = -1.*log(0.9999999) 291 rec2p13=1./2.13 292 293 ncolprint=0 294 295 if ( debug.ne.0 ) then 296 j=1 3 SUBROUTINE ICARUS( & 4 debug, & 5 debugcol, & 6 npoints, & 7 sunlit, & 8 nlev, & 9 ncol, & 10 pfull, & 11 phalf, & 12 qv, & 13 cc, & 14 conv, & 15 dtau_s, & 16 dtau_c, & 17 top_height, & 18 top_height_direction, & 19 overlap, & 20 frac_out, & 21 skt, & 22 emsfc_lw, & 23 at, & 24 dem_s, & 25 dem_c, & 26 fq_isccp, & 27 totalcldarea, & 28 meanptop, & 29 meantaucld, & 30 meanalbedocld, & 31 meantb, & 32 meantbclr, & 33 boxtau, & 34 boxptop & 35 ) 36 37 !$Id: icarus.f,v 4.1 2010/05/27 16:30:18 hadmw Exp $ 38 39 ! *****************************COPYRIGHT**************************** 40 ! (c) 2009, Lawrence Livermore National Security Limited Liability 41 ! Corporation. 42 ! All rights reserved. 43 ! 44 ! Redistribution and use in source and binary forms, with or without 45 ! modification, are permitted provided that the 46 ! following conditions are met: 47 ! 48 ! * Redistributions of source code must retain the above 49 ! copyright notice, this list of conditions and the following 50 ! disclaimer. 51 ! * Redistributions in binary form must reproduce the above 52 ! copyright notice, this list of conditions and the following 53 ! disclaimer in the documentation and/or other materials 54 ! provided with the distribution. 55 ! * Neither the name of the Lawrence Livermore National Security 56 ! Limited Liability Corporation nor the names of its 57 ! contributors may be used to endorse or promote products 58 ! derived from this software without specific prior written 59 ! permission. 60 ! 61 ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 62 ! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 63 ! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 64 ! A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 65 ! OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 66 ! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 67 ! LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 68 ! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 69 ! THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 70 ! (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 71 ! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 72 ! 73 ! *****************************COPYRIGHT******************************* 74 ! *****************************COPYRIGHT******************************* 75 ! *****************************COPYRIGHT******************************* 76 ! *****************************COPYRIGHT******************************* 77 78 implicit none 79 80 ! NOTE: the maximum number of levels and columns is set by 81 ! the following parameter statement 82 83 INTEGER :: ncolprint 84 85 ! ----- 86 ! Input 87 ! ----- 88 89 INTEGER :: npoints ! number of model points in the horizontal 90 INTEGER :: nlev ! number of model levels in column 91 INTEGER :: ncol ! number of subcolumns 92 93 INTEGER :: sunlit(npoints) ! 1 for day points, 0 for night time 94 95 REAL :: pfull(npoints,nlev) 96 ! ! pressure of full model levels (Pascals) 97 ! ! pfull(npoints,1) is top level of model 98 ! ! pfull(npoints,nlev) is bot of model 99 100 REAL :: phalf(npoints,nlev+1) 101 ! ! pressure of half model levels (Pascals) 102 ! ! phalf(npoints,1) is top of model 103 ! ! phalf(npoints,nlev+1) is the surface pressure 104 105 REAL :: qv(npoints,nlev) 106 ! ! water vapor specific humidity (kg vapor/ kg air) 107 ! ! on full model levels 108 109 REAL :: cc(npoints,nlev) 110 ! ! input cloud cover in each model level (fraction) 111 ! ! NOTE: This is the HORIZONTAL area of each 112 ! ! grid box covered by clouds 113 114 REAL :: conv(npoints,nlev) 115 ! ! input convective cloud cover in each model 116 ! ! level (fraction) 117 ! ! NOTE: This is the HORIZONTAL area of each 118 ! ! grid box covered by convective clouds 119 120 REAL :: dtau_s(npoints,nlev) 121 ! ! mean 0.67 micron optical depth of stratiform 122 ! ! clouds in each model level 123 ! ! NOTE: this the cloud optical depth of only the 124 ! ! cloudy part of the grid box, it is not weighted 125 ! ! with the 0 cloud optical depth of the clear 126 ! ! part of the grid box 127 128 REAL :: dtau_c(npoints,nlev) 129 ! ! mean 0.67 micron optical depth of convective 130 ! ! clouds in each 131 ! ! model level. Same note applies as in dtau_s. 132 133 INTEGER :: overlap ! overlap type 134 ! ! 1=max 135 ! ! 2=rand 136 ! ! 3=max/rand 137 138 INTEGER :: top_height ! 1 = adjust top height using both a computed 139 ! ! infrared brightness temperature and the visible 140 ! ! optical depth to adjust cloud top pressure. Note 141 ! ! that this calculation is most appropriate to compare 142 ! ! to ISCCP data during sunlit hours. 143 ! ! 2 = do not adjust top height, that is cloud top 144 ! ! pressure is the actual cloud top pressure 145 ! ! in the model 146 ! ! 3 = adjust top height using only the computed 147 ! ! infrared brightness temperature. Note that this 148 ! ! calculation is most appropriate to compare to ISCCP 149 ! ! IR only algortihm (i.e. you can compare to nighttime 150 ! ! ISCCP data with this option) 151 152 INTEGER :: top_height_direction ! direction for finding atmosphere pressure level 153 ! ! with interpolated temperature equal to the radiance 154 ! determined cloud-top temperature 155 ! 156 ! 1 = find the *lowest* altitude (highest pressure) level 157 ! with interpolated temperature equal to the radiance 158 ! determined cloud-top temperature 159 ! 160 ! 2 = find the *highest* altitude (lowest pressure) level 161 ! with interpolated temperature equal to the radiance 162 ! determined cloud-top temperature 163 ! 164 ! ONLY APPLICABLE IF top_height EQUALS 1 or 3 165 ! ! 166 ! 1 = old setting: matches all versions of 167 ! ISCCP simulator with versions numbers 3.5.1 and lower 168 ! 169 ! 2 = default setting: for version numbers 4.0 and higher 170 ! 171 ! The following input variables are used only if top_height = 1 or top_height = 3 172 ! 173 REAL :: skt(npoints) ! skin Temperature (K) 174 REAL :: emsfc_lw ! 10.5 micron emissivity of surface (fraction) 175 REAL :: at(npoints,nlev) ! temperature in each model level (K) 176 REAL :: dem_s(npoints,nlev) ! 10.5 micron longwave emissivity of stratiform 177 ! ! clouds in each 178 ! ! model level. Same note applies as in dtau_s. 179 REAL :: dem_c(npoints,nlev) ! 10.5 micron longwave emissivity of convective 180 ! ! clouds in each 181 ! ! model level. Same note applies as in dtau_s. 182 183 REAL :: frac_out(npoints,ncol,nlev) ! boxes gridbox divided up into 184 ! ! Equivalent of BOX in original version, but 185 ! ! indexed by column then row, rather than 186 ! ! by row then column 187 188 189 190 ! ------ 191 ! Output 192 ! ------ 193 194 REAL :: fq_isccp(npoints,7,7) ! the fraction of the model grid box covered by 195 ! ! each of the 49 ISCCP D level cloud types 196 197 REAL :: totalcldarea(npoints) ! the fraction of model grid box columns 198 ! ! with cloud somewhere in them. NOTE: This diagnostic 199 ! does not count model clouds with tau < isccp_taumin 200 ! ! Thus this diagnostic does not equal the sum over all entries of fq_isccp. 201 ! However, this diagnostic does equal the sum over entries of fq_isccp with 202 ! itau = 2:7 (omitting itau = 1) 203 204 205 ! ! The following three means are averages only over the cloudy areas with tau > isccp_taumin. 206 ! ! If no clouds with tau > isccp_taumin are in grid box all three quantities should equal zero. 207 208 REAL :: meanptop(npoints) ! mean cloud top pressure (mb) - linear averaging 209 ! ! in cloud top pressure. 210 211 REAL :: meantaucld(npoints) ! mean optical thickness 212 ! ! linear averaging in albedo performed. 213 214 real :: meanalbedocld(npoints) ! mean cloud albedo 215 ! ! linear averaging in albedo performed 216 217 real :: meantb(npoints) ! mean all-sky 10.5 micron brightness temperature 218 219 real :: meantbclr(npoints) ! mean clear-sky 10.5 micron brightness temperature 220 221 REAL :: boxtau(npoints,ncol) ! optical thickness in each column 222 223 REAL :: boxptop(npoints,ncol) ! cloud top pressure (mb) in each column 224 225 226 ! 227 ! ------ 228 ! Working variables added when program updated to mimic Mark Webb's PV-Wave code 229 ! ------ 230 231 REAL :: dem(npoints,ncol),bb(npoints) ! working variables for 10.5 micron longwave 232 ! ! emissivity in part of 233 ! ! gridbox under consideration 234 235 REAL :: ptrop(npoints) 236 REAL :: attrop(npoints) 237 REAL :: attropmin (npoints) 238 REAL :: atmax(npoints) 239 REAL :: btcmin(npoints) 240 REAL :: transmax(npoints) 241 242 INTEGER :: i,j,ilev,ibox,itrop(npoints) 243 INTEGER :: ipres(npoints) 244 INTEGER :: itau(npoints),ilev2 245 INTEGER :: acc(nlev,ncol) 246 INTEGER :: match(npoints,nlev-1) 247 INTEGER :: nmatch(npoints) 248 INTEGER :: levmatch(npoints,ncol) 249 250 ! !variables needed for water vapor continuum absorption 251 real :: fluxtop_clrsky(npoints),trans_layers_above_clrsky(npoints) 252 real :: taumin(npoints) 253 real :: dem_wv(npoints,nlev), wtmair, wtmh20, Navo, grav, pstd, t0 254 real :: press(npoints), dpress(npoints), atmden(npoints) 255 real :: rvh20(npoints), wk(npoints), rhoave(npoints) 256 real :: rh20s(npoints), rfrgn(npoints) 257 real :: tmpexp(npoints),tauwv(npoints) 258 259 character(len=1) :: cchar(6),cchar_realtops(6) 260 integer :: icycle 261 REAL :: tau(npoints,ncol) 262 LOGICAL :: box_cloudy(npoints,ncol) 263 REAL :: tb(npoints,ncol) 264 REAL :: ptop(npoints,ncol) 265 REAL :: emcld(npoints,ncol) 266 REAL :: fluxtop(npoints,ncol) 267 REAL :: trans_layers_above(npoints,ncol) 268 real :: isccp_taumin,fluxtopinit(npoints),tauir(npoints) 269 REAL :: albedocld(npoints,ncol) 270 real :: boxarea 271 integer :: debug ! set to non-zero value to print out inputs 272 ! ! with step debug 273 integer :: debugcol ! set to non-zero value to print out column 274 ! ! decomposition with step debugcol 275 integer :: rangevec(npoints),rangeerror 276 277 integer :: index1(npoints),num1,jj,k1,k2 278 real :: rec2p13,tauchk,logp,logp1,logp2,atd 279 real :: output_missing_value 280 281 character(len=10) :: ftn09 282 283 DATA isccp_taumin / 0.3 / 284 DATA output_missing_value / -1.E+30 / 285 DATA cchar / ' ','-','1','+','I','+'/ 286 DATA cchar_realtops / ' ',' ','1','1','I','I'/ 287 288 ! ------ End duplicate definitions common to wrapper routine 289 290 tauchk = -1.*log(0.9999999) 291 rec2p13=1./2.13 292 293 ncolprint=0 294 295 if ( debug.ne.0 ) then 296 j=1 297 write(6,'(a10)') 'j=' 298 write(6,'(8I10)') j 299 write(6,'(a10)') 'debug=' 300 write(6,'(8I10)') debug 301 write(6,'(a10)') 'debugcol=' 302 write(6,'(8I10)') debugcol 303 write(6,'(a10)') 'npoints=' 304 write(6,'(8I10)') npoints 305 write(6,'(a10)') 'nlev=' 306 write(6,'(8I10)') nlev 307 write(6,'(a10)') 'ncol=' 308 write(6,'(8I10)') ncol 309 write(6,'(a11)') 'top_height=' 310 write(6,'(8I10)') top_height 311 write(6,'(a21)') 'top_height_direction=' 312 write(6,'(8I10)') top_height_direction 313 write(6,'(a10)') 'overlap=' 314 write(6,'(8I10)') overlap 315 write(6,'(a10)') 'emsfc_lw=' 316 write(6,'(8f10.2)') emsfc_lw 317 do j=1,npoints,debug 318 write(6,'(a10)') 'j=' 319 write(6,'(8I10)') j 320 write(6,'(a10)') 'sunlit=' 321 write(6,'(8I10)') sunlit(j) 322 write(6,'(a10)') 'pfull=' 323 write(6,'(8f10.2)') (pfull(j,i),i=1,nlev) 324 write(6,'(a10)') 'phalf=' 325 write(6,'(8f10.2)') (phalf(j,i),i=1,nlev+1) 326 write(6,'(a10)') 'qv=' 327 write(6,'(8f10.3)') (qv(j,i),i=1,nlev) 328 write(6,'(a10)') 'cc=' 329 write(6,'(8f10.3)') (cc(j,i),i=1,nlev) 330 write(6,'(a10)') 'conv=' 331 write(6,'(8f10.2)') (conv(j,i),i=1,nlev) 332 write(6,'(a10)') 'dtau_s=' 333 write(6,'(8g12.5)') (dtau_s(j,i),i=1,nlev) 334 write(6,'(a10)') 'dtau_c=' 335 write(6,'(8f10.2)') (dtau_c(j,i),i=1,nlev) 336 write(6,'(a10)') 'skt=' 337 write(6,'(8f10.2)') skt(j) 338 write(6,'(a10)') 'at=' 339 write(6,'(8f10.2)') (at(j,i),i=1,nlev) 340 write(6,'(a10)') 'dem_s=' 341 write(6,'(8f10.3)') (dem_s(j,i),i=1,nlev) 342 write(6,'(a10)') 'dem_c=' 343 write(6,'(8f10.3)') (dem_c(j,i),i=1,nlev) 344 enddo 345 endif 346 347 ! ---------------------------------------------------! 348 349 if (ncolprint.ne.0) then 350 do j=1,npoints,1000 351 write(6,'(a10)') 'j=' 352 write(6,'(8I10)') j 353 enddo 354 endif 355 356 if (top_height .eq. 1 .or. top_height .eq. 3) then 357 358 do j=1,npoints 359 ptrop(j)=5000. 360 attropmin(j) = 400. 361 atmax(j) = 0. 362 attrop(j) = 120. 363 itrop(j) = 1 364 enddo 365 366 do ilev=1,nlev 367 do j=1,npoints 368 if (pfull(j,ilev) .lt. 40000. .and. & 369 pfull(j,ilev) .gt. 5000. .and. & 370 at(j,ilev) .lt. attropmin(j)) then 371 ptrop(j) = pfull(j,ilev) 372 attropmin(j) = at(j,ilev) 373 attrop(j) = attropmin(j) 374 itrop(j)=ilev 375 end if 376 enddo 377 end do 378 379 do ilev=1,nlev 380 do j=1,npoints 381 if (at(j,ilev) .gt. atmax(j) .and. & 382 ilev .ge. itrop(j)) atmax(j)=at(j,ilev) 383 enddo 384 end do 385 386 end if 387 388 389 if (top_height .eq. 1 .or. top_height .eq. 3) then 390 do j=1,npoints 391 meantb(j) = 0. 392 meantbclr(j) = 0. 393 end do 394 else 395 do j=1,npoints 396 meantb(j) = output_missing_value 397 meantbclr(j) = output_missing_value 398 end do 399 end if 400 401 ! -----------------------------------------------------! 402 403 ! ---------------------------------------------------! 404 405 do ilev=1,nlev 406 do j=1,npoints 407 408 rangevec(j)=0 409 410 if (cc(j,ilev) .lt. 0. .or. cc(j,ilev) .gt. 1.) then 411 ! error = cloud fraction less than zero 412 ! error = cloud fraction greater than 1 413 rangevec(j)=rangevec(j)+1 414 endif 415 416 if (conv(j,ilev) .lt. 0. .or. conv(j,ilev) .gt. 1.) then 417 ! ' error = convective cloud fraction less than zero' 418 ! ' error = convective cloud fraction greater than 1' 419 rangevec(j)=rangevec(j)+2 420 endif 421 422 if (dtau_s(j,ilev) .lt. 0.) then 423 ! ' error = stratiform cloud opt. depth less than zero' 424 rangevec(j)=rangevec(j)+4 425 endif 426 427 if (dtau_c(j,ilev) .lt. 0.) then 428 ! ' error = convective cloud opt. depth less than zero' 429 rangevec(j)=rangevec(j)+8 430 endif 431 432 if (dem_s(j,ilev) .lt. 0. .or. dem_s(j,ilev) .gt. 1.) then 433 ! ' error = stratiform cloud emissivity less than zero' 434 ! ' error = stratiform cloud emissivity greater than 1' 435 rangevec(j)=rangevec(j)+16 436 endif 437 438 if (dem_c(j,ilev) .lt. 0. .or. dem_c(j,ilev) .gt. 1.) then 439 ! ' error = convective cloud emissivity less than zero' 440 ! ' error = convective cloud emissivity greater than 1' 441 rangevec(j)=rangevec(j)+32 442 endif 443 enddo 444 445 rangeerror=0 446 do j=1,npoints 447 rangeerror=rangeerror+rangevec(j) 448 enddo 449 450 if (rangeerror.ne.0) then 451 write (6,*) 'Input variable out of range' 452 write (6,*) 'rangevec:' 453 write (6,*) rangevec 454 STOP 455 endif 456 enddo 457 458 ! 459 ! ---------------------------------------------------! 460 461 462 ! 463 ! ---------------------------------------------------! 464 ! COMPUTE CLOUD OPTICAL DEPTH FOR EACH COLUMN and 465 ! put into vector tau 466 467 ! !initialize tau and albedocld to zero 468 do ibox=1,ncol 469 do j=1,npoints 470 tau(j,ibox)=0. 471 albedocld(j,ibox)=0. 472 boxtau(j,ibox)=output_missing_value 473 boxptop(j,ibox)=output_missing_value 474 box_cloudy(j,ibox)=.false. 475 enddo 476 end do 477 478 ! !compute total cloud optical depth for each column 479 do ilev=1,nlev 480 ! !increment tau for each of the boxes 481 do ibox=1,ncol 482 do j=1,npoints 483 if (frac_out(j,ibox,ilev).eq.1) then 484 tau(j,ibox)=tau(j,ibox) & 485 + dtau_s(j,ilev) 486 endif 487 if (frac_out(j,ibox,ilev).eq.2) then 488 tau(j,ibox)=tau(j,ibox) & 489 + dtau_c(j,ilev) 490 end if 491 enddo 492 enddo ! ibox 493 enddo ! ilev 494 if (ncolprint.ne.0) then 495 496 do j=1,npoints ,1000 497 write(6,'(a10)') 'j=' 498 write(6,'(8I10)') j 499 write(6,'(i2,1X,8(f7.2,1X))') & 500 ilev, & 501 (tau(j,ibox),ibox=1,ncolprint) 502 enddo 503 endif 504 ! 505 ! ---------------------------------------------------! 506 507 508 509 ! 510 ! ---------------------------------------------------! 511 ! COMPUTE INFRARED BRIGHTNESS TEMPERUATRES 512 ! AND CLOUD TOP TEMPERATURE SATELLITE SHOULD SEE 513 ! 514 ! again this is only done if top_height = 1 or 3 515 ! 516 ! fluxtop is the 10.5 micron radiance at the top of the 517 ! atmosphere 518 ! trans_layers_above is the total transmissivity in the layers 519 ! above the current layer 520 ! fluxtop_clrsky(j) and trans_layers_above_clrsky(j) are the clear 521 ! sky versions of these quantities. 522 523 if (top_height .eq. 1 .or. top_height .eq. 3) then 524 525 526 ! !---------------------------------------------------------------------- 527 ! ! 528 ! ! DO CLEAR SKY RADIANCE CALCULATION FIRST 529 ! ! 530 ! !compute water vapor continuum emissivity 531 ! !this treatment follows Schwarkzopf and Ramasamy 532 ! !JGR 1999,vol 104, pages 9467-9499. 533 ! !the emissivity is calculated at a wavenumber of 955 cm-1, 534 ! !or 10.47 microns 535 wtmair = 28.9644 536 wtmh20 = 18.01534 537 Navo = 6.023E+23 538 grav = 9.806650E+02 539 pstd = 1.013250E+06 540 t0 = 296. 541 if (ncolprint .ne. 0) & 542 write(6,*) 'ilev pw (kg/m2) tauwv(j) dem_wv' 543 do ilev=1,nlev 544 do j=1,npoints 545 ! !press and dpress are dyne/cm2 = Pascals *10 546 press(j) = pfull(j,ilev)*10. 547 dpress(j) = (phalf(j,ilev+1)-phalf(j,ilev))*10 548 ! !atmden = g/cm2 = kg/m2 / 10 549 atmden(j) = dpress(j)/grav 550 rvh20(j) = qv(j,ilev)*wtmair/wtmh20 551 wk(j) = rvh20(j)*Navo*atmden(j)/wtmair 552 rhoave(j) = (press(j)/pstd)*(t0/at(j,ilev)) 553 rh20s(j) = rvh20(j)*rhoave(j) 554 rfrgn(j) = rhoave(j)-rh20s(j) 555 tmpexp(j) = exp(-0.02*(at(j,ilev)-t0)) 556 tauwv(j) = wk(j)*1.e-20*( & 557 (0.0224697*rh20s(j)*tmpexp(j)) + & 558 (3.41817e-7*rfrgn(j)) )*0.98 559 dem_wv(j,ilev) = 1. - exp( -1. * tauwv(j)) 560 enddo 561 if (ncolprint .ne. 0) then 562 do j=1,npoints ,1000 563 write(6,'(a10)') 'j=' 564 write(6,'(8I10)') j 565 write(6,'(i2,1X,3(f8.3,3X))') ilev, & 566 qv(j,ilev)*(phalf(j,ilev+1)-phalf(j,ilev))/(grav/100.), & 567 tauwv(j),dem_wv(j,ilev) 568 enddo 569 endif 570 end do 571 572 ! !initialize variables 573 do j=1,npoints 574 fluxtop_clrsky(j) = 0. 575 trans_layers_above_clrsky(j)=1. 576 enddo 577 578 do ilev=1,nlev 579 do j=1,npoints 580 581 ! ! Black body emission at temperature of the layer 582 583 bb(j)=1 / ( exp(1307.27/at(j,ilev)) - 1. ) 584 ! !bb(j)= 5.67e-8*at(j,ilev)**4 585 586 ! ! increase TOA flux by flux emitted from layer 587 ! ! times total transmittance in layers above 588 589 fluxtop_clrsky(j) = fluxtop_clrsky(j) & 590 + dem_wv(j,ilev)*bb(j)*trans_layers_above_clrsky(j) 591 592 ! ! update trans_layers_above with transmissivity 593 ! ! from this layer for next time around loop 594 595 trans_layers_above_clrsky(j)= & 596 trans_layers_above_clrsky(j)*(1.-dem_wv(j,ilev)) 597 598 599 enddo 600 if (ncolprint.ne.0) then 601 do j=1,npoints ,1000 297 602 write(6,'(a10)') 'j=' 298 603 write(6,'(8I10)') j 299 write(6,'(a10)') 'debug=' 300 write(6,'(8I10)') debug 301 write(6,'(a10)') 'debugcol=' 302 write(6,'(8I10)') debugcol 303 write(6,'(a10)') 'npoints=' 304 write(6,'(8I10)') npoints 305 write(6,'(a10)') 'nlev=' 306 write(6,'(8I10)') nlev 307 write(6,'(a10)') 'ncol=' 308 write(6,'(8I10)') ncol 309 write(6,'(a11)') 'top_height=' 310 write(6,'(8I10)') top_height 311 write(6,'(a21)') 'top_height_direction=' 312 write(6,'(8I10)') top_height_direction 313 write(6,'(a10)') 'overlap=' 314 write(6,'(8I10)') overlap 315 write(6,'(a10)') 'emsfc_lw=' 316 write(6,'(8f10.2)') emsfc_lw 317 do j=1,npoints,debug 604 write (6,'(a)') 'ilev:' 605 write (6,'(I2)') ilev 606 607 write (6,'(a)') & 608 'emiss_layer,100.*bb(j),100.*f,total_trans:' 609 write (6,'(4(f7.2,1X))') dem_wv(j,ilev),100.*bb(j), & 610 100.*fluxtop_clrsky(j),trans_layers_above_clrsky(j) 611 enddo 612 endif 613 614 enddo !loop over level 615 616 do j=1,npoints 617 ! !add in surface emission 618 bb(j)=1/( exp(1307.27/skt(j)) - 1. ) 619 ! !bb(j)=5.67e-8*skt(j)**4 620 621 fluxtop_clrsky(j) = fluxtop_clrsky(j) + emsfc_lw * bb(j) & 622 * trans_layers_above_clrsky(j) 623 624 ! !clear sky brightness temperature 625 meantbclr(j) = 1307.27/(log(1.+(1./fluxtop_clrsky(j)))) 626 627 enddo 628 629 if (ncolprint.ne.0) then 630 do j=1,npoints ,1000 631 write(6,'(a10)') 'j=' 632 write(6,'(8I10)') j 633 write (6,'(a)') 'id:' 634 write (6,'(a)') 'surface' 635 636 write (6,'(a)') 'emsfc,100.*bb(j),100.*f,total_trans:' 637 write (6,'(5(f7.2,1X))') emsfc_lw,100.*bb(j), & 638 100.*fluxtop_clrsky(j), & 639 trans_layers_above_clrsky(j), meantbclr(j) 640 enddo 641 endif 642 643 644 ! ! 645 ! ! END OF CLEAR SKY CALCULATION 646 ! ! 647 ! !---------------------------------------------------------------- 648 649 650 651 if (ncolprint.ne.0) then 652 653 do j=1,npoints ,1000 654 write(6,'(a10)') 'j=' 655 write(6,'(8I10)') j 656 write (6,'(a)') 'ts:' 657 write (6,'(8f7.2)') (skt(j),ibox=1,ncolprint) 658 659 write (6,'(a)') 'ta_rev:' 660 write (6,'(8f7.2)') & 661 ((at(j,ilev2),ibox=1,ncolprint),ilev2=1,nlev) 662 663 enddo 664 endif 665 ! !loop over columns 666 do ibox=1,ncol 667 do j=1,npoints 668 fluxtop(j,ibox)=0. 669 trans_layers_above(j,ibox)=1. 670 enddo 671 enddo 672 673 do ilev=1,nlev 674 do j=1,npoints 675 ! ! Black body emission at temperature of the layer 676 677 bb(j)=1 / ( exp(1307.27/at(j,ilev)) - 1. ) 678 ! !bb(j)= 5.67e-8*at(j,ilev)**4 679 enddo 680 681 do ibox=1,ncol 682 do j=1,npoints 683 684 ! ! emissivity for point in this layer 685 if (frac_out(j,ibox,ilev).eq.1) then 686 dem(j,ibox)= 1. - & 687 ( (1. - dem_wv(j,ilev)) * (1. - dem_s(j,ilev)) ) 688 else if (frac_out(j,ibox,ilev).eq.2) then 689 dem(j,ibox)= 1. - & 690 ( (1. - dem_wv(j,ilev)) * (1. - dem_c(j,ilev)) ) 691 else 692 dem(j,ibox)= dem_wv(j,ilev) 693 end if 694 695 696 ! ! increase TOA flux by flux emitted from layer 697 ! ! times total transmittance in layers above 698 699 fluxtop(j,ibox) = fluxtop(j,ibox) & 700 + dem(j,ibox) * bb(j) & 701 * trans_layers_above(j,ibox) 702 703 ! ! update trans_layers_above with transmissivity 704 ! ! from this layer for next time around loop 705 706 trans_layers_above(j,ibox)= & 707 trans_layers_above(j,ibox)*(1.-dem(j,ibox)) 708 709 enddo ! j 710 enddo ! ibox 711 712 if (ncolprint.ne.0) then 713 do j=1,npoints,1000 714 write (6,'(a)') 'ilev:' 715 write (6,'(I2)') ilev 716 318 717 write(6,'(a10)') 'j=' 319 718 write(6,'(8I10)') j 320 write(6,'(a10)') 'sunlit=' 321 write(6,'(8I10)') sunlit(j) 322 write(6,'(a10)') 'pfull=' 323 write(6,'(8f10.2)') (pfull(j,i),i=1,nlev) 324 write(6,'(a10)') 'phalf=' 325 write(6,'(8f10.2)') (phalf(j,i),i=1,nlev+1) 326 write(6,'(a10)') 'qv=' 327 write(6,'(8f10.3)') (qv(j,i),i=1,nlev) 328 write(6,'(a10)') 'cc=' 329 write(6,'(8f10.3)') (cc(j,i),i=1,nlev) 330 write(6,'(a10)') 'conv=' 331 write(6,'(8f10.2)') (conv(j,i),i=1,nlev) 332 write(6,'(a10)') 'dtau_s=' 333 write(6,'(8g12.5)') (dtau_s(j,i),i=1,nlev) 334 write(6,'(a10)') 'dtau_c=' 335 write(6,'(8f10.2)') (dtau_c(j,i),i=1,nlev) 336 write(6,'(a10)') 'skt=' 337 write(6,'(8f10.2)') skt(j) 338 write(6,'(a10)') 'at=' 339 write(6,'(8f10.2)') (at(j,i),i=1,nlev) 340 write(6,'(a10)') 'dem_s=' 341 write(6,'(8f10.3)') (dem_s(j,i),i=1,nlev) 342 write(6,'(a10)') 'dem_c=' 343 write(6,'(8f10.3)') (dem_c(j,i),i=1,nlev) 719 write (6,'(a)') 'emiss_layer:' 720 write (6,'(8f7.2)') (dem(j,ibox),ibox=1,ncolprint) 721 722 write (6,'(a)') '100.*bb(j):' 723 write (6,'(8f7.2)') (100.*bb(j),ibox=1,ncolprint) 724 725 write (6,'(a)') '100.*f:' 726 write (6,'(8f7.2)') & 727 (100.*fluxtop(j,ibox),ibox=1,ncolprint) 728 729 write (6,'(a)') 'total_trans:' 730 write (6,'(8f7.2)') & 731 (trans_layers_above(j,ibox),ibox=1,ncolprint) 344 732 enddo 345 733 endif 346 734 347 ! ---------------------------------------------------! 348 349 if (ncolprint.ne.0) then 735 enddo ! ilev 736 737 738 do j=1,npoints 739 ! !add in surface emission 740 bb(j)=1/( exp(1307.27/skt(j)) - 1. ) 741 ! !bb(j)=5.67e-8*skt(j)**4 742 end do 743 744 do ibox=1,ncol 745 do j=1,npoints 746 747 ! !add in surface emission 748 749 fluxtop(j,ibox) = fluxtop(j,ibox) & 750 + emsfc_lw * bb(j) & 751 * trans_layers_above(j,ibox) 752 753 end do 754 end do 755 756 ! !calculate mean infrared brightness temperature 757 do ibox=1,ncol 758 do j=1,npoints 759 meantb(j) = meantb(j)+1307.27/(log(1.+(1./fluxtop(j,ibox)))) 760 end do 761 end do 762 do j=1, npoints 763 meantb(j) = meantb(j) / real(ncol) 764 end do 765 766 if (ncolprint.ne.0) then 767 768 do j=1,npoints ,1000 769 write(6,'(a10)') 'j=' 770 write(6,'(8I10)') j 771 write (6,'(a)') 'id:' 772 write (6,'(a)') 'surface' 773 774 write (6,'(a)') 'emiss_layer:' 775 write (6,'(8f7.2)') (dem(1,ibox),ibox=1,ncolprint) 776 777 write (6,'(a)') '100.*bb(j):' 778 write (6,'(8f7.2)') (100.*bb(j),ibox=1,ncolprint) 779 780 write (6,'(a)') '100.*f:' 781 write (6,'(8f7.2)') (100.*fluxtop(j,ibox),ibox=1,ncolprint) 782 783 write (6,'(a)') 'meantb(j):' 784 write (6,'(8f7.2)') (meantb(j),ibox=1,ncolprint) 785 786 end do 787 endif 788 789 ! !now that you have the top of atmosphere radiance account 790 ! !for ISCCP procedures to determine cloud top temperature 791 792 ! !account for partially transmitting cloud recompute flux 793 ! !ISCCP would see assuming a single layer cloud 794 ! !note choice here of 2.13, as it is primarily ice 795 ! !clouds which have partial emissivity and need the 796 ! !adjustment performed in this section 797 ! ! 798 ! !If it turns out that the cloud brightness temperature 799 ! !is greater than 260K, then the liquid cloud conversion 800 ! !factor of 2.56 is used. 801 ! ! 802 ! !Note that this is discussed on pages 85-87 of 803 ! !the ISCCP D level documentation (Rossow et al. 1996) 804 805 do j=1,npoints 806 ! !compute minimum brightness temperature and optical depth 807 btcmin(j) = 1. / ( exp(1307.27/(attrop(j)-5.)) - 1. ) 808 enddo 809 do ibox=1,ncol 810 do j=1,npoints 811 transmax(j) = (fluxtop(j,ibox)-btcmin(j)) & 812 /(fluxtop_clrsky(j)-btcmin(j)) 813 ! !note that the initial setting of tauir(j) is needed so that 814 ! !tauir(j) has a realistic value should the next if block be 815 ! !bypassed 816 tauir(j) = tau(j,ibox) * rec2p13 817 taumin(j) = -1. * log(max(min(transmax(j),0.9999999),0.001)) 818 819 enddo 820 821 if (top_height .eq. 1) then 822 do j=1,npoints 823 if (transmax(j) .gt. 0.001 .and. & 824 transmax(j) .le. 0.9999999) then 825 fluxtopinit(j) = fluxtop(j,ibox) 826 tauir(j) = tau(j,ibox) *rec2p13 827 endif 828 enddo 829 do icycle=1,2 830 do j=1,npoints 831 if (tau(j,ibox) .gt. (tauchk )) then 832 if (transmax(j) .gt. 0.001 .and. & 833 transmax(j) .le. 0.9999999) then 834 emcld(j,ibox) = 1. - exp(-1. * tauir(j) ) 835 fluxtop(j,ibox) = fluxtopinit(j) - & 836 ((1.-emcld(j,ibox))*fluxtop_clrsky(j)) 837 fluxtop(j,ibox)=max(1.E-06, & 838 (fluxtop(j,ibox)/emcld(j,ibox))) 839 tb(j,ibox)= 1307.27 & 840 / (log(1. + (1./fluxtop(j,ibox)))) 841 if (tb(j,ibox) .gt. 260.) then 842 tauir(j) = tau(j,ibox) / 2.56 843 end if 844 end if 845 end if 846 enddo 847 enddo 848 849 endif 850 851 do j=1,npoints 852 if (tau(j,ibox) .gt. (tauchk )) then 853 ! !cloudy box 854 !NOTE: tb is the cloud-top temperature not infrared brightness temperature 855 !at this point in the code 856 tb(j,ibox)= 1307.27/ (log(1. + (1./fluxtop(j,ibox)))) 857 if (top_height.eq.1.and.tauir(j).lt.taumin(j)) then 858 tb(j,ibox) = attrop(j) - 5. 859 tau(j,ibox) = 2.13*taumin(j) 860 end if 861 else 862 ! !clear sky brightness temperature 863 tb(j,ibox) = meantbclr(j) 864 end if 865 enddo ! j 866 enddo ! ibox 867 868 if (ncolprint.ne.0) then 869 350 870 do j=1,npoints,1000 351 write(6,'(a10)') 'j=' 352 write(6,'(8I10)') j 871 write(6,'(a10)') 'j=' 872 write(6,'(8I10)') j 873 874 write (6,'(a)') 'attrop:' 875 write (6,'(8f7.2)') (attrop(j)) 876 877 write (6,'(a)') 'btcmin:' 878 write (6,'(8f7.2)') (btcmin(j)) 879 880 write (6,'(a)') 'fluxtop_clrsky*100:' 881 write (6,'(8f7.2)') & 882 (100.*fluxtop_clrsky(j)) 883 884 write (6,'(a)') '100.*f_adj:' 885 write (6,'(8f7.2)') (100.*fluxtop(j,ibox),ibox=1,ncolprint) 886 887 write (6,'(a)') 'transmax:' 888 write (6,'(8f7.2)') (transmax(ibox),ibox=1,ncolprint) 889 890 write (6,'(a)') 'tau:' 891 write (6,'(8f7.2)') (tau(j,ibox),ibox=1,ncolprint) 892 893 write (6,'(a)') 'emcld:' 894 write (6,'(8f7.2)') (emcld(j,ibox),ibox=1,ncolprint) 895 896 write (6,'(a)') 'total_trans:' 897 write (6,'(8f7.2)') & 898 (trans_layers_above(j,ibox),ibox=1,ncolprint) 899 900 write (6,'(a)') 'total_emiss:' 901 write (6,'(8f7.2)') & 902 (1.0-trans_layers_above(j,ibox),ibox=1,ncolprint) 903 904 write (6,'(a)') 'total_trans:' 905 write (6,'(8f7.2)') & 906 (trans_layers_above(j,ibox),ibox=1,ncolprint) 907 908 write (6,'(a)') 'ppout:' 909 write (6,'(8f7.2)') (tb(j,ibox),ibox=1,ncolprint) 910 enddo ! j 911 endif 912 913 end if 914 915 ! ---------------------------------------------------! 916 917 ! 918 ! ---------------------------------------------------! 919 ! DETERMINE CLOUD TOP PRESSURE 920 ! 921 ! again the 2 methods differ according to whether 922 ! or not you use the physical cloud top pressure (top_height = 2) 923 ! or the radiatively determined cloud top pressure (top_height = 1 or 3) 924 ! 925 926 ! !compute cloud top pressure 927 do ibox=1,ncol 928 ! !segregate according to optical thickness 929 if (top_height .eq. 1 .or. top_height .eq. 3) then 930 ! !find level whose temperature 931 ! !most closely matches brightness temperature 932 do j=1,npoints 933 nmatch(j)=0 353 934 enddo 354 endif 355 356 if (top_height .eq. 1 .or. top_height .eq. 3) then 357 358 do j=1,npoints 359 ptrop(j)=5000. 360 attropmin(j) = 400. 361 atmax(j) = 0. 362 attrop(j) = 120. 363 itrop(j) = 1 364 enddo 365 366 do 12 ilev=1,nlev 367 do j=1,npoints 368 if (pfull(j,ilev) .lt. 40000. .and. 369 & pfull(j,ilev) .gt. 5000. .and. 370 & at(j,ilev) .lt. attropmin(j)) then 371 ptrop(j) = pfull(j,ilev) 372 attropmin(j) = at(j,ilev) 373 attrop(j) = attropmin(j) 374 itrop(j)=ilev 375 end if 935 do k1=1,nlev-1 936 if (top_height_direction .eq. 2) then 937 ilev = nlev - k1 938 else 939 ilev = k1 940 end if 941 ! !cdir nodep 942 do j=1,npoints 943 if (ilev .ge. itrop(j)) then 944 if ((at(j,ilev) .ge. tb(j,ibox) .and. & 945 at(j,ilev+1) .le. tb(j,ibox)) .or. & 946 (at(j,ilev) .le. tb(j,ibox) .and. & 947 at(j,ilev+1) .ge. tb(j,ibox))) then 948 nmatch(j)=nmatch(j)+1 949 match(j,nmatch(j))=ilev 950 end if 951 end if 376 952 enddo 377 12 continue 378 379 do 13 ilev=1,nlev 380 do j=1,npoints 381 if (at(j,ilev) .gt. atmax(j) .and. 382 & ilev .ge. itrop(j)) atmax(j)=at(j,ilev) 383 enddo 384 13 continue 385 386 end if 387 388 389 if (top_height .eq. 1 .or. top_height .eq. 3) then 390 do j=1,npoints 391 meantb(j) = 0. 392 meantbclr(j) = 0. 393 end do 394 else 395 do j=1,npoints 396 meantb(j) = output_missing_value 397 meantbclr(j) = output_missing_value 398 end do 399 end if 400 401 ! -----------------------------------------------------! 402 403 ! ---------------------------------------------------! 404 953 end do 954 955 do j=1,npoints 956 if (nmatch(j) .ge. 1) then 957 k1 = match(j,nmatch(j)) 958 k2 = k1 + 1 959 logp1 = log(pfull(j,k1)) 960 logp2 = log(pfull(j,k2)) 961 atd = max(tauchk,abs(at(j,k2) - at(j,k1))) 962 logp=logp1+(logp2-logp1)*abs(tb(j,ibox)-at(j,k1))/atd 963 ptop(j,ibox) = exp(logp) 964 if(abs(pfull(j,k1)-ptop(j,ibox)) .lt. & 965 abs(pfull(j,k2)-ptop(j,ibox))) then 966 levmatch(j,ibox)=k1 967 else 968 levmatch(j,ibox)=k2 969 end if 970 else 971 if (tb(j,ibox) .le. attrop(j)) then 972 ptop(j,ibox)=ptrop(j) 973 levmatch(j,ibox)=itrop(j) 974 end if 975 if (tb(j,ibox) .ge. atmax(j)) then 976 ptop(j,ibox)=pfull(j,nlev) 977 levmatch(j,ibox)=nlev 978 end if 979 end if 980 enddo ! j 981 982 else ! if (top_height .eq. 1 .or. top_height .eq. 3) 983 984 do j=1,npoints 985 ptop(j,ibox)=0. 986 enddo 405 987 do ilev=1,nlev 406 988 do j=1,npoints 407 408 rangevec(j)=0 409 410 if (cc(j,ilev) .lt. 0. .or. cc(j,ilev) .gt. 1.) then 411 ! error = cloud fraction less than zero 412 ! error = cloud fraction greater than 1 413 rangevec(j)=rangevec(j)+1 414 endif 415 416 if (conv(j,ilev) .lt. 0. .or. conv(j,ilev) .gt. 1.) then 417 ! ' error = convective cloud fraction less than zero' 418 ! ' error = convective cloud fraction greater than 1' 419 rangevec(j)=rangevec(j)+2 420 endif 421 422 if (dtau_s(j,ilev) .lt. 0.) then 423 ! ' error = stratiform cloud opt. depth less than zero' 424 rangevec(j)=rangevec(j)+4 425 endif 426 427 if (dtau_c(j,ilev) .lt. 0.) then 428 ! ' error = convective cloud opt. depth less than zero' 429 rangevec(j)=rangevec(j)+8 430 endif 431 432 if (dem_s(j,ilev) .lt. 0. .or. dem_s(j,ilev) .gt. 1.) then 433 ! ' error = stratiform cloud emissivity less than zero' 434 ! ' error = stratiform cloud emissivity greater than 1' 435 rangevec(j)=rangevec(j)+16 436 endif 437 438 if (dem_c(j,ilev) .lt. 0. .or. dem_c(j,ilev) .gt. 1.) then 439 ! ' error = convective cloud emissivity less than zero' 440 ! ' error = convective cloud emissivity greater than 1' 441 rangevec(j)=rangevec(j)+32 442 endif 443 enddo 444 445 rangeerror=0 446 do j=1,npoints 447 rangeerror=rangeerror+rangevec(j) 448 enddo 449 450 if (rangeerror.ne.0) then 451 write (6,*) 'Input variable out of range' 452 write (6,*) 'rangevec:' 453 write (6,*) rangevec 454 STOP 989 if ((ptop(j,ibox) .eq. 0. ) & 990 .and.(frac_out(j,ibox,ilev) .ne. 0)) then 991 ptop(j,ibox)=phalf(j,ilev) 992 levmatch(j,ibox)=ilev 993 end if 994 end do 995 end do 996 end if 997 998 do j=1,npoints 999 if (tau(j,ibox) .le. (tauchk )) then 1000 ptop(j,ibox)=0. 1001 levmatch(j,ibox)=0 1002 endif 1003 enddo 1004 1005 end do 1006 1007 ! 1008 ! 1009 ! ---------------------------------------------------! 1010 1011 1012 ! 1013 ! ---------------------------------------------------! 1014 ! DETERMINE ISCCP CLOUD TYPE FREQUENCIES 1015 ! 1016 ! Now that ptop and tau have been determined, 1017 ! determine amount of each of the 49 ISCCP cloud 1018 ! types 1019 ! 1020 ! Also compute grid box mean cloud top pressure and 1021 ! optical thickness. The mean cloud top pressure and 1022 ! optical thickness are averages over the cloudy 1023 ! area only. The mean cloud top pressure is a linear 1024 ! average of the cloud top pressures. The mean cloud 1025 ! optical thickness is computed by converting optical 1026 ! thickness to an albedo, averaging in albedo units, 1027 ! then converting the average albedo back to a mean 1028 ! optical thickness. 1029 ! 1030 1031 ! !compute isccp frequencies 1032 1033 ! !reset frequencies 1034 do ilev=1,7 1035 do ilev2=1,7 1036 do j=1,npoints ! 1037 if (sunlit(j).eq.1 .or. top_height .eq. 3) then 1038 fq_isccp(j,ilev,ilev2)= 0. 1039 else 1040 fq_isccp(j,ilev,ilev2)= output_missing_value 1041 end if 1042 enddo 1043 end do 1044 end do 1045 1046 ! !reset variables need for averaging cloud properties 1047 do j=1,npoints 1048 if (sunlit(j).eq.1 .or. top_height .eq. 3) then 1049 totalcldarea(j) = 0. 1050 meanalbedocld(j) = 0. 1051 meanptop(j) = 0. 1052 meantaucld(j) = 0. 1053 else 1054 totalcldarea(j) = output_missing_value 1055 meanalbedocld(j) = output_missing_value 1056 meanptop(j) = output_missing_value 1057 meantaucld(j) = output_missing_value 1058 end if 1059 enddo ! j 1060 1061 boxarea = 1./real(ncol) 1062 1063 do ibox=1,ncol 1064 do j=1,npoints 1065 1066 if (tau(j,ibox) .gt. (tauchk ) & 1067 .and. ptop(j,ibox) .gt. 0.) then 1068 box_cloudy(j,ibox)=.true. 1069 endif 1070 1071 if (box_cloudy(j,ibox)) then 1072 1073 if (sunlit(j).eq.1 .or. top_height .eq. 3) then 1074 1075 boxtau(j,ibox) = tau(j,ibox) 1076 1077 if (tau(j,ibox) .ge. isccp_taumin) then 1078 totalcldarea(j) = totalcldarea(j) + boxarea 1079 1080 ! !convert optical thickness to albedo 1081 albedocld(j,ibox) & 1082 = (tau(j,ibox)**0.895)/((tau(j,ibox)**0.895)+6.82) 1083 1084 ! !contribute to averaging 1085 meanalbedocld(j) = meanalbedocld(j) & 1086 +albedocld(j,ibox)*boxarea 1087 1088 end if 1089 455 1090 endif 456 enddo 457 458 ! 459 ! ---------------------------------------------------! 460 461 462 ! 463 ! ---------------------------------------------------! 464 ! COMPUTE CLOUD OPTICAL DEPTH FOR EACH COLUMN and 465 ! put into vector tau 466 467 !initialize tau and albedocld to zero 468 do 15 ibox=1,ncol 469 do j=1,npoints 470 tau(j,ibox)=0. 471 albedocld(j,ibox)=0. 472 boxtau(j,ibox)=output_missing_value 473 boxptop(j,ibox)=output_missing_value 474 box_cloudy(j,ibox)=.false. 475 enddo 476 15 continue 477 478 !compute total cloud optical depth for each column 479 do ilev=1,nlev 480 !increment tau for each of the boxes 481 do ibox=1,ncol 482 do j=1,npoints 483 if (frac_out(j,ibox,ilev).eq.1) then 484 tau(j,ibox)=tau(j,ibox) 485 & + dtau_s(j,ilev) 486 endif 487 if (frac_out(j,ibox,ilev).eq.2) then 488 tau(j,ibox)=tau(j,ibox) 489 & + dtau_c(j,ilev) 490 end if 491 enddo 492 enddo ! ibox 493 enddo ! ilev 494 if (ncolprint.ne.0) then 495 496 do j=1,npoints ,1000 497 write(6,'(a10)') 'j=' 498 write(6,'(8I10)') j 499 write(6,'(i2,1X,8(f7.2,1X))') 500 & ilev, 501 & (tau(j,ibox),ibox=1,ncolprint) 502 enddo 503 endif 504 ! 505 ! ---------------------------------------------------! 506 507 508 509 ! 510 ! ---------------------------------------------------! 511 ! COMPUTE INFRARED BRIGHTNESS TEMPERUATRES 512 ! AND CLOUD TOP TEMPERATURE SATELLITE SHOULD SEE 513 ! 514 ! again this is only done if top_height = 1 or 3 515 ! 516 ! fluxtop is the 10.5 micron radiance at the top of the 517 ! atmosphere 518 ! trans_layers_above is the total transmissivity in the layers 519 ! above the current layer 520 ! fluxtop_clrsky(j) and trans_layers_above_clrsky(j) are the clear 521 ! sky versions of these quantities. 522 523 if (top_height .eq. 1 .or. top_height .eq. 3) then 524 525 526 !---------------------------------------------------------------------- 527 ! 528 ! DO CLEAR SKY RADIANCE CALCULATION FIRST 529 ! 530 !compute water vapor continuum emissivity 531 !this treatment follows Schwarkzopf and Ramasamy 532 !JGR 1999,vol 104, pages 9467-9499. 533 !the emissivity is calculated at a wavenumber of 955 cm-1, 534 !or 10.47 microns 535 wtmair = 28.9644 536 wtmh20 = 18.01534 537 Navo = 6.023E+23 538 grav = 9.806650E+02 539 pstd = 1.013250E+06 540 t0 = 296. 541 if (ncolprint .ne. 0) 542 & write(6,*) 'ilev pw (kg/m2) tauwv(j) dem_wv' 543 do 125 ilev=1,nlev 544 do j=1,npoints 545 !press and dpress are dyne/cm2 = Pascals *10 546 press(j) = pfull(j,ilev)*10. 547 dpress(j) = (phalf(j,ilev+1)-phalf(j,ilev))*10 548 !atmden = g/cm2 = kg/m2 / 10 549 atmden(j) = dpress(j)/grav 550 rvh20(j) = qv(j,ilev)*wtmair/wtmh20 551 wk(j) = rvh20(j)*Navo*atmden(j)/wtmair 552 rhoave(j) = (press(j)/pstd)*(t0/at(j,ilev)) 553 rh20s(j) = rvh20(j)*rhoave(j) 554 rfrgn(j) = rhoave(j)-rh20s(j) 555 tmpexp(j) = exp(-0.02*(at(j,ilev)-t0)) 556 tauwv(j) = wk(j)*1.e-20*( 557 & (0.0224697*rh20s(j)*tmpexp(j)) + 558 & (3.41817e-7*rfrgn(j)) )*0.98 559 dem_wv(j,ilev) = 1. - exp( -1. * tauwv(j)) 560 enddo 561 if (ncolprint .ne. 0) then 562 do j=1,npoints ,1000 563 write(6,'(a10)') 'j=' 564 write(6,'(8I10)') j 565 write(6,'(i2,1X,3(f8.3,3X))') ilev, 566 & qv(j,ilev)*(phalf(j,ilev+1)-phalf(j,ilev))/(grav/100.), 567 & tauwv(j),dem_wv(j,ilev) 568 enddo 569 endif 570 125 continue 571 572 !initialize variables 573 do j=1,npoints 574 fluxtop_clrsky(j) = 0. 575 trans_layers_above_clrsky(j)=1. 576 enddo 577 1091 1092 endif 1093 1094 if (sunlit(j).eq.1 .or. top_height .eq. 3) then 1095 1096 if (box_cloudy(j,ibox)) then 1097 1098 ! !convert ptop to millibars 1099 ptop(j,ibox)=ptop(j,ibox) / 100. 1100 1101 ! !save for output cloud top pressure and optical thickness 1102 boxptop(j,ibox) = ptop(j,ibox) 1103 1104 if (tau(j,ibox) .ge. isccp_taumin) then 1105 meanptop(j) = meanptop(j) + ptop(j,ibox)*boxarea 1106 end if 1107 1108 ! !reset itau(j), ipres(j) 1109 itau(j) = 0 1110 ipres(j) = 0 1111 1112 ! !determine optical depth category 1113 if (tau(j,ibox) .lt. isccp_taumin) then 1114 itau(j)=1 1115 else if (tau(j,ibox) .ge. isccp_taumin & 1116 & 1117 .and. tau(j,ibox) .lt. 1.3) then 1118 itau(j)=2 1119 else if (tau(j,ibox) .ge. 1.3 & 1120 .and. tau(j,ibox) .lt. 3.6) then 1121 itau(j)=3 1122 else if (tau(j,ibox) .ge. 3.6 & 1123 .and. tau(j,ibox) .lt. 9.4) then 1124 itau(j)=4 1125 else if (tau(j,ibox) .ge. 9.4 & 1126 .and. tau(j,ibox) .lt. 23.) then 1127 itau(j)=5 1128 else if (tau(j,ibox) .ge. 23. & 1129 .and. tau(j,ibox) .lt. 60.) then 1130 itau(j)=6 1131 else if (tau(j,ibox) .ge. 60.) then 1132 itau(j)=7 1133 end if 1134 1135 ! !determine cloud top pressure category 1136 if ( ptop(j,ibox) .gt. 0. & 1137 .and.ptop(j,ibox) .lt. 180.) then 1138 ipres(j)=1 1139 else if(ptop(j,ibox) .ge. 180. & 1140 .and.ptop(j,ibox) .lt. 310.) then 1141 ipres(j)=2 1142 else if(ptop(j,ibox) .ge. 310. & 1143 .and.ptop(j,ibox) .lt. 440.) then 1144 ipres(j)=3 1145 else if(ptop(j,ibox) .ge. 440. & 1146 .and.ptop(j,ibox) .lt. 560.) then 1147 ipres(j)=4 1148 else if(ptop(j,ibox) .ge. 560. & 1149 .and.ptop(j,ibox) .lt. 680.) then 1150 ipres(j)=5 1151 else if(ptop(j,ibox) .ge. 680. & 1152 .and.ptop(j,ibox) .lt. 800.) then 1153 ipres(j)=6 1154 else if(ptop(j,ibox) .ge. 800.) then 1155 ipres(j)=7 1156 end if 1157 1158 ! !update frequencies 1159 if(ipres(j) .gt. 0.and.itau(j) .gt. 0) then 1160 fq_isccp(j,itau(j),ipres(j))= & 1161 fq_isccp(j,itau(j),ipres(j))+ boxarea 1162 end if 1163 1164 end if 1165 1166 end if 1167 1168 enddo ! j 1169 end do 1170 1171 ! !compute mean cloud properties 1172 do j=1,npoints 1173 if (totalcldarea(j) .gt. 0.) then 1174 ! code above guarantees that totalcldarea > 0 1175 ! only if sunlit .eq. 1 .or. top_height = 3 1176 ! and applies only to clouds with tau > isccp_taumin 1177 meanptop(j) = meanptop(j) / totalcldarea(j) 1178 meanalbedocld(j) = meanalbedocld(j) / totalcldarea(j) 1179 meantaucld(j) = (6.82/((1./meanalbedocld(j))-1.))**(1./0.895) 1180 else 1181 ! this code is necessary so that in the case that totalcldarea = 0., 1182 ! that these variables, which are in-cloud averages, are set to missing 1183 ! note that totalcldarea will be 0. if all the clouds in the grid box have 1184 ! tau < isccp_taumin 1185 meanptop(j) = output_missing_value 1186 meanalbedocld(j) = output_missing_value 1187 meantaucld(j) = output_missing_value 1188 end if 1189 enddo ! j 1190 ! 1191 ! ---------------------------------------------------! 1192 1193 ! ---------------------------------------------------! 1194 ! OPTIONAL PRINTOUT OF DATA TO CHECK PROGRAM 1195 ! 1196 if (debugcol.ne.0) then 1197 ! 1198 do j=1,npoints,debugcol 1199 1200 ! !produce character output 578 1201 do ilev=1,nlev 579 do j=1,npoints 580 581 ! Black body emission at temperature of the layer 582 583 bb(j)=1 / ( exp(1307.27/at(j,ilev)) - 1. ) 584 !bb(j)= 5.67e-8*at(j,ilev)**4 585 586 ! increase TOA flux by flux emitted from layer 587 ! times total transmittance in layers above 588 589 fluxtop_clrsky(j) = fluxtop_clrsky(j) 590 & + dem_wv(j,ilev)*bb(j)*trans_layers_above_clrsky(j) 591 592 ! update trans_layers_above with transmissivity 593 ! from this layer for next time around loop 594 595 trans_layers_above_clrsky(j)= 596 & trans_layers_above_clrsky(j)*(1.-dem_wv(j,ilev)) 597 598 599 enddo 600 if (ncolprint.ne.0) then 601 do j=1,npoints ,1000 602 write(6,'(a10)') 'j=' 603 write(6,'(8I10)') j 604 write (6,'(a)') 'ilev:' 605 write (6,'(I2)') ilev 606 607 write (6,'(a)') 608 & 'emiss_layer,100.*bb(j),100.*f,total_trans:' 609 write (6,'(4(f7.2,1X))') dem_wv(j,ilev),100.*bb(j), 610 & 100.*fluxtop_clrsky(j),trans_layers_above_clrsky(j) 611 enddo 612 endif 613 614 enddo !loop over level 615 616 do j=1,npoints 617 !add in surface emission 618 bb(j)=1/( exp(1307.27/skt(j)) - 1. ) 619 !bb(j)=5.67e-8*skt(j)**4 620 621 fluxtop_clrsky(j) = fluxtop_clrsky(j) + emsfc_lw * bb(j) 622 & * trans_layers_above_clrsky(j) 623 624 !clear sky brightness temperature 625 meantbclr(j) = 1307.27/(log(1.+(1./fluxtop_clrsky(j)))) 626 627 enddo 628 629 if (ncolprint.ne.0) then 630 do j=1,npoints ,1000 631 write(6,'(a10)') 'j=' 632 write(6,'(8I10)') j 633 write (6,'(a)') 'id:' 634 write (6,'(a)') 'surface' 635 636 write (6,'(a)') 'emsfc,100.*bb(j),100.*f,total_trans:' 637 write (6,'(5(f7.2,1X))') emsfc_lw,100.*bb(j), 638 & 100.*fluxtop_clrsky(j), 639 & trans_layers_above_clrsky(j), meantbclr(j) 640 enddo 641 endif 642 643 644 ! 645 ! END OF CLEAR SKY CALCULATION 646 ! 647 !---------------------------------------------------------------- 648 649 650 651 if (ncolprint.ne.0) then 652 653 do j=1,npoints ,1000 654 write(6,'(a10)') 'j=' 655 write(6,'(8I10)') j 656 write (6,'(a)') 'ts:' 657 write (6,'(8f7.2)') (skt(j),ibox=1,ncolprint) 658 659 write (6,'(a)') 'ta_rev:' 660 write (6,'(8f7.2)') 661 & ((at(j,ilev2),ibox=1,ncolprint),ilev2=1,nlev) 662 663 enddo 664 endif 665 !loop over columns 666 do ibox=1,ncol 667 do j=1,npoints 668 fluxtop(j,ibox)=0. 669 trans_layers_above(j,ibox)=1. 1202 do ibox=1,ncol 1203 acc(ilev,ibox)=0 670 1204 enddo 671 1205 enddo 672 1206 673 1207 do ilev=1,nlev 674 do j=1,npoints 675 ! Black body emission at temperature of the layer 676 677 bb(j)=1 / ( exp(1307.27/at(j,ilev)) - 1. ) 678 !bb(j)= 5.67e-8*at(j,ilev)**4 679 enddo 680 681 do ibox=1,ncol 682 do j=1,npoints 683 684 ! emissivity for point in this layer 685 if (frac_out(j,ibox,ilev).eq.1) then 686 dem(j,ibox)= 1. - 687 & ( (1. - dem_wv(j,ilev)) * (1. - dem_s(j,ilev)) ) 688 else if (frac_out(j,ibox,ilev).eq.2) then 689 dem(j,ibox)= 1. - 690 & ( (1. - dem_wv(j,ilev)) * (1. - dem_c(j,ilev)) ) 691 else 692 dem(j,ibox)= dem_wv(j,ilev) 693 end if 694 695 696 ! increase TOA flux by flux emitted from layer 697 ! times total transmittance in layers above 698 699 fluxtop(j,ibox) = fluxtop(j,ibox) 700 & + dem(j,ibox) * bb(j) 701 & * trans_layers_above(j,ibox) 702 703 ! update trans_layers_above with transmissivity 704 ! from this layer for next time around loop 705 706 trans_layers_above(j,ibox)= 707 & trans_layers_above(j,ibox)*(1.-dem(j,ibox)) 708 709 enddo ! j 710 enddo ! ibox 711 712 if (ncolprint.ne.0) then 713 do j=1,npoints,1000 714 write (6,'(a)') 'ilev:' 715 write (6,'(I2)') ilev 716 717 write(6,'(a10)') 'j=' 718 write(6,'(8I10)') j 719 write (6,'(a)') 'emiss_layer:' 720 write (6,'(8f7.2)') (dem(j,ibox),ibox=1,ncolprint) 721 722 write (6,'(a)') '100.*bb(j):' 723 write (6,'(8f7.2)') (100.*bb(j),ibox=1,ncolprint) 724 725 write (6,'(a)') '100.*f:' 726 write (6,'(8f7.2)') 727 & (100.*fluxtop(j,ibox),ibox=1,ncolprint) 728 729 write (6,'(a)') 'total_trans:' 730 write (6,'(8f7.2)') 731 & (trans_layers_above(j,ibox),ibox=1,ncolprint) 732 enddo 733 endif 734 735 enddo ! ilev 736 737 738 do j=1,npoints 739 !add in surface emission 740 bb(j)=1/( exp(1307.27/skt(j)) - 1. ) 741 !bb(j)=5.67e-8*skt(j)**4 742 end do 743 744 do ibox=1,ncol 745 do j=1,npoints 746 747 !add in surface emission 748 749 fluxtop(j,ibox) = fluxtop(j,ibox) 750 & + emsfc_lw * bb(j) 751 & * trans_layers_above(j,ibox) 752 753 end do 754 end do 755 756 !calculate mean infrared brightness temperature 757 do ibox=1,ncol 758 do j=1,npoints 759 meantb(j) = meantb(j)+1307.27/(log(1.+(1./fluxtop(j,ibox)))) 760 end do 761 end do 762 do j=1, npoints 763 meantb(j) = meantb(j) / real(ncol) 764 end do 765 766 if (ncolprint.ne.0) then 767 768 do j=1,npoints ,1000 769 write(6,'(a10)') 'j=' 770 write(6,'(8I10)') j 771 write (6,'(a)') 'id:' 772 write (6,'(a)') 'surface' 773 774 write (6,'(a)') 'emiss_layer:' 775 write (6,'(8f7.2)') (dem(1,ibox),ibox=1,ncolprint) 776 777 write (6,'(a)') '100.*bb(j):' 778 write (6,'(8f7.2)') (100.*bb(j),ibox=1,ncolprint) 779 780 write (6,'(a)') '100.*f:' 781 write (6,'(8f7.2)') (100.*fluxtop(j,ibox),ibox=1,ncolprint) 782 783 write (6,'(a)') 'meantb(j):' 784 write (6,'(8f7.2)') (meantb(j),ibox=1,ncolprint) 785 786 end do 787 endif 788 789 !now that you have the top of atmosphere radiance account 790 !for ISCCP procedures to determine cloud top temperature 791 792 !account for partially transmitting cloud recompute flux 793 !ISCCP would see assuming a single layer cloud 794 !note choice here of 2.13, as it is primarily ice 795 !clouds which have partial emissivity and need the 796 !adjustment performed in this section 797 ! 798 !If it turns out that the cloud brightness temperature 799 !is greater than 260K, then the liquid cloud conversion 800 !factor of 2.56 is used. 801 ! 802 !Note that this is discussed on pages 85-87 of 803 !the ISCCP D level documentation (Rossow et al. 1996) 804 805 do j=1,npoints 806 !compute minimum brightness temperature and optical depth 807 btcmin(j) = 1. / ( exp(1307.27/(attrop(j)-5.)) - 1. ) 808 enddo 809 do ibox=1,ncol 810 do j=1,npoints 811 transmax(j) = (fluxtop(j,ibox)-btcmin(j)) 812 & /(fluxtop_clrsky(j)-btcmin(j)) 813 !note that the initial setting of tauir(j) is needed so that 814 !tauir(j) has a realistic value should the next if block be 815 !bypassed 816 tauir(j) = tau(j,ibox) * rec2p13 817 taumin(j) = -1. * log(max(min(transmax(j),0.9999999),0.001)) 818 819 enddo 820 821 if (top_height .eq. 1) then 822 do j=1,npoints 823 if (transmax(j) .gt. 0.001 .and. 824 & transmax(j) .le. 0.9999999) then 825 fluxtopinit(j) = fluxtop(j,ibox) 826 tauir(j) = tau(j,ibox) *rec2p13 827 endif 828 enddo 829 do icycle=1,2 830 do j=1,npoints 831 if (tau(j,ibox) .gt. (tauchk )) then 832 if (transmax(j) .gt. 0.001 .and. 833 & transmax(j) .le. 0.9999999) then 834 emcld(j,ibox) = 1. - exp(-1. * tauir(j) ) 835 fluxtop(j,ibox) = fluxtopinit(j) - 836 & ((1.-emcld(j,ibox))*fluxtop_clrsky(j)) 837 fluxtop(j,ibox)=max(1.E-06, 838 & (fluxtop(j,ibox)/emcld(j,ibox))) 839 tb(j,ibox)= 1307.27 840 & / (log(1. + (1./fluxtop(j,ibox)))) 841 if (tb(j,ibox) .gt. 260.) then 842 tauir(j) = tau(j,ibox) / 2.56 843 end if 844 end if 845 end if 846 enddo 847 enddo 848 849 endif 850 851 do j=1,npoints 852 if (tau(j,ibox) .gt. (tauchk )) then 853 !cloudy box 854 !NOTE: tb is the cloud-top temperature not infrared brightness temperature 855 !at this point in the code 856 tb(j,ibox)= 1307.27/ (log(1. + (1./fluxtop(j,ibox)))) 857 if (top_height.eq.1.and.tauir(j).lt.taumin(j)) then 858 tb(j,ibox) = attrop(j) - 5. 859 tau(j,ibox) = 2.13*taumin(j) 860 end if 861 else 862 !clear sky brightness temperature 863 tb(j,ibox) = meantbclr(j) 864 end if 865 enddo ! j 866 enddo ! ibox 867 868 if (ncolprint.ne.0) then 869 870 do j=1,npoints,1000 871 write(6,'(a10)') 'j=' 872 write(6,'(8I10)') j 873 874 write (6,'(a)') 'attrop:' 875 write (6,'(8f7.2)') (attrop(j)) 876 877 write (6,'(a)') 'btcmin:' 878 write (6,'(8f7.2)') (btcmin(j)) 879 880 write (6,'(a)') 'fluxtop_clrsky*100:' 881 write (6,'(8f7.2)') 882 & (100.*fluxtop_clrsky(j)) 883 884 write (6,'(a)') '100.*f_adj:' 885 write (6,'(8f7.2)') (100.*fluxtop(j,ibox),ibox=1,ncolprint) 886 887 write (6,'(a)') 'transmax:' 888 write (6,'(8f7.2)') (transmax(ibox),ibox=1,ncolprint) 889 890 write (6,'(a)') 'tau:' 891 write (6,'(8f7.2)') (tau(j,ibox),ibox=1,ncolprint) 892 893 write (6,'(a)') 'emcld:' 894 write (6,'(8f7.2)') (emcld(j,ibox),ibox=1,ncolprint) 895 896 write (6,'(a)') 'total_trans:' 897 write (6,'(8f7.2)') 898 & (trans_layers_above(j,ibox),ibox=1,ncolprint) 899 900 write (6,'(a)') 'total_emiss:' 901 write (6,'(8f7.2)') 902 & (1.0-trans_layers_above(j,ibox),ibox=1,ncolprint) 903 904 write (6,'(a)') 'total_trans:' 905 write (6,'(8f7.2)') 906 & (trans_layers_above(j,ibox),ibox=1,ncolprint) 907 908 write (6,'(a)') 'ppout:' 909 write (6,'(8f7.2)') (tb(j,ibox),ibox=1,ncolprint) 910 enddo ! j 911 endif 912 913 end if 914 915 ! ---------------------------------------------------! 916 917 ! 918 ! ---------------------------------------------------! 919 ! DETERMINE CLOUD TOP PRESSURE 920 ! 921 ! again the 2 methods differ according to whether 922 ! or not you use the physical cloud top pressure (top_height = 2) 923 ! or the radiatively determined cloud top pressure (top_height = 1 or 3) 924 ! 925 926 !compute cloud top pressure 927 do 30 ibox=1,ncol 928 !segregate according to optical thickness 929 if (top_height .eq. 1 .or. top_height .eq. 3) then 930 !find level whose temperature 931 !most closely matches brightness temperature 932 do j=1,npoints 933 nmatch(j)=0 1208 do ibox=1,ncol 1209 acc(ilev,ibox)=frac_out(j,ibox,ilev)*2 1210 if (levmatch(j,ibox) .eq. ilev) & 1211 acc(ilev,ibox)=acc(ilev,ibox)+1 934 1212 enddo 935 do 29 k1=1,nlev-1936 if (top_height_direction .eq. 2) then937 ilev = nlev - k1938 else939 ilev = k1940 end if941 !cdir nodep942 do j=1,npoints943 if (ilev .ge. itrop(j)) then944 if ((at(j,ilev) .ge. tb(j,ibox) .and.945 & at(j,ilev+1) .le. tb(j,ibox)) .or.946 & (at(j,ilev) .le. tb(j,ibox) .and.947 & at(j,ilev+1) .ge. tb(j,ibox))) then948 nmatch(j)=nmatch(j)+1949 match(j,nmatch(j))=ilev950 end if951 end if952 enddo953 29 continue954 955 do j=1,npoints956 if (nmatch(j) .ge. 1) then957 k1 = match(j,nmatch(j))958 k2 = k1 + 1959 logp1 = log(pfull(j,k1))960 logp2 = log(pfull(j,k2))961 atd = max(tauchk,abs(at(j,k2) - at(j,k1)))962 logp=logp1+(logp2-logp1)*abs(tb(j,ibox)-at(j,k1))/atd963 ptop(j,ibox) = exp(logp)964 if(abs(pfull(j,k1)-ptop(j,ibox)) .lt.965 & abs(pfull(j,k2)-ptop(j,ibox))) then966 levmatch(j,ibox)=k1967 else968 levmatch(j,ibox)=k2969 end if970 else971 if (tb(j,ibox) .le. attrop(j)) then972 ptop(j,ibox)=ptrop(j)973 levmatch(j,ibox)=itrop(j)974 end if975 if (tb(j,ibox) .ge. atmax(j)) then976 ptop(j,ibox)=pfull(j,nlev)977 levmatch(j,ibox)=nlev978 end if979 end if980 enddo ! j981 982 else ! if (top_height .eq. 1 .or. top_height .eq. 3)983 984 do j=1,npoints985 ptop(j,ibox)=0.986 enddo987 do ilev=1,nlev988 do j=1,npoints989 if ((ptop(j,ibox) .eq. 0. )990 & .and.(frac_out(j,ibox,ilev) .ne. 0)) then991 ptop(j,ibox)=phalf(j,ilev)992 levmatch(j,ibox)=ilev993 end if994 end do995 end do996 end if997 998 do j=1,npoints999 if (tau(j,ibox) .le. (tauchk )) then1000 ptop(j,ibox)=0.1001 levmatch(j,ibox)=01002 endif1003 1213 enddo 1004 1214 1005 30 continue 1006 1007 ! 1008 ! 1009 ! ---------------------------------------------------! 1010 1011 1012 ! 1013 ! ---------------------------------------------------! 1014 ! DETERMINE ISCCP CLOUD TYPE FREQUENCIES 1015 ! 1016 ! Now that ptop and tau have been determined, 1017 ! determine amount of each of the 49 ISCCP cloud 1018 ! types 1019 ! 1020 ! Also compute grid box mean cloud top pressure and 1021 ! optical thickness. The mean cloud top pressure and 1022 ! optical thickness are averages over the cloudy 1023 ! area only. The mean cloud top pressure is a linear 1024 ! average of the cloud top pressures. The mean cloud 1025 ! optical thickness is computed by converting optical 1026 ! thickness to an albedo, averaging in albedo units, 1027 ! then converting the average albedo back to a mean 1028 ! optical thickness. 1029 ! 1030 1031 !compute isccp frequencies 1032 1033 !reset frequencies 1034 do 38 ilev=1,7 1035 do 38 ilev2=1,7 1036 do j=1,npoints ! 1037 if (sunlit(j).eq.1 .or. top_height .eq. 3) then 1038 fq_isccp(j,ilev,ilev2)= 0. 1039 else 1040 fq_isccp(j,ilev,ilev2)= output_missing_value 1041 end if 1042 enddo 1043 38 continue 1044 1045 !reset variables need for averaging cloud properties 1046 do j=1,npoints 1047 if (sunlit(j).eq.1 .or. top_height .eq. 3) then 1048 totalcldarea(j) = 0. 1049 meanalbedocld(j) = 0. 1050 meanptop(j) = 0. 1051 meantaucld(j) = 0. 1052 else 1053 totalcldarea(j) = output_missing_value 1054 meanalbedocld(j) = output_missing_value 1055 meanptop(j) = output_missing_value 1056 meantaucld(j) = output_missing_value 1057 end if 1058 enddo ! j 1059 1060 boxarea = 1./real(ncol) 1061 1062 do 39 ibox=1,ncol 1063 do j=1,npoints 1064 1065 if (tau(j,ibox) .gt. (tauchk ) 1066 & .and. ptop(j,ibox) .gt. 0.) then 1067 box_cloudy(j,ibox)=.true. 1068 endif 1069 1070 if (box_cloudy(j,ibox)) then 1071 1072 if (sunlit(j).eq.1 .or. top_height .eq. 3) then 1073 1074 boxtau(j,ibox) = tau(j,ibox) 1075 1076 if (tau(j,ibox) .ge. isccp_taumin) then 1077 totalcldarea(j) = totalcldarea(j) + boxarea 1078 1079 !convert optical thickness to albedo 1080 albedocld(j,ibox) 1081 & = (tau(j,ibox)**0.895)/((tau(j,ibox)**0.895)+6.82) 1082 1083 !contribute to averaging 1084 meanalbedocld(j) = meanalbedocld(j) 1085 & +albedocld(j,ibox)*boxarea 1086 1087 end if 1088 1089 endif 1090 1091 endif 1092 1093 if (sunlit(j).eq.1 .or. top_height .eq. 3) then 1094 1095 if (box_cloudy(j,ibox)) then 1096 1097 !convert ptop to millibars 1098 ptop(j,ibox)=ptop(j,ibox) / 100. 1099 1100 !save for output cloud top pressure and optical thickness 1101 boxptop(j,ibox) = ptop(j,ibox) 1102 1103 if (tau(j,ibox) .ge. isccp_taumin) then 1104 meanptop(j) = meanptop(j) + ptop(j,ibox)*boxarea 1105 end if 1106 1107 !reset itau(j), ipres(j) 1108 itau(j) = 0 1109 ipres(j) = 0 1110 1111 !determine optical depth category 1112 if (tau(j,ibox) .lt. isccp_taumin) then 1113 itau(j)=1 1114 else if (tau(j,ibox) .ge. isccp_taumin 1115 & 1116 & .and. tau(j,ibox) .lt. 1.3) then 1117 itau(j)=2 1118 else if (tau(j,ibox) .ge. 1.3 1119 & .and. tau(j,ibox) .lt. 3.6) then 1120 itau(j)=3 1121 else if (tau(j,ibox) .ge. 3.6 1122 & .and. tau(j,ibox) .lt. 9.4) then 1123 itau(j)=4 1124 else if (tau(j,ibox) .ge. 9.4 1125 & .and. tau(j,ibox) .lt. 23.) then 1126 itau(j)=5 1127 else if (tau(j,ibox) .ge. 23. 1128 & .and. tau(j,ibox) .lt. 60.) then 1129 itau(j)=6 1130 else if (tau(j,ibox) .ge. 60.) then 1131 itau(j)=7 1132 end if 1133 1134 !determine cloud top pressure category 1135 if ( ptop(j,ibox) .gt. 0. 1136 & .and.ptop(j,ibox) .lt. 180.) then 1137 ipres(j)=1 1138 else if(ptop(j,ibox) .ge. 180. 1139 & .and.ptop(j,ibox) .lt. 310.) then 1140 ipres(j)=2 1141 else if(ptop(j,ibox) .ge. 310. 1142 & .and.ptop(j,ibox) .lt. 440.) then 1143 ipres(j)=3 1144 else if(ptop(j,ibox) .ge. 440. 1145 & .and.ptop(j,ibox) .lt. 560.) then 1146 ipres(j)=4 1147 else if(ptop(j,ibox) .ge. 560. 1148 & .and.ptop(j,ibox) .lt. 680.) then 1149 ipres(j)=5 1150 else if(ptop(j,ibox) .ge. 680. 1151 & .and.ptop(j,ibox) .lt. 800.) then 1152 ipres(j)=6 1153 else if(ptop(j,ibox) .ge. 800.) then 1154 ipres(j)=7 1155 end if 1156 1157 !update frequencies 1158 if(ipres(j) .gt. 0.and.itau(j) .gt. 0) then 1159 fq_isccp(j,itau(j),ipres(j))= 1160 & fq_isccp(j,itau(j),ipres(j))+ boxarea 1161 end if 1162 1163 end if 1164 1165 end if 1166 1167 enddo ! j 1168 39 continue 1169 1170 !compute mean cloud properties 1171 do j=1,npoints 1172 if (totalcldarea(j) .gt. 0.) then 1173 ! code above guarantees that totalcldarea > 0 1174 ! only if sunlit .eq. 1 .or. top_height = 3 1175 ! and applies only to clouds with tau > isccp_taumin 1176 meanptop(j) = meanptop(j) / totalcldarea(j) 1177 meanalbedocld(j) = meanalbedocld(j) / totalcldarea(j) 1178 meantaucld(j) = (6.82/((1./meanalbedocld(j))-1.))**(1./0.895) 1179 else 1180 ! this code is necessary so that in the case that totalcldarea = 0., 1181 ! that these variables, which are in-cloud averages, are set to missing 1182 ! note that totalcldarea will be 0. if all the clouds in the grid box have 1183 ! tau < isccp_taumin 1184 meanptop(j) = output_missing_value 1185 meanalbedocld(j) = output_missing_value 1186 meantaucld(j) = output_missing_value 1187 end if 1188 enddo ! j 1189 ! 1190 ! ---------------------------------------------------! 1191 1192 ! ---------------------------------------------------! 1193 ! OPTIONAL PRINTOUT OF DATA TO CHECK PROGRAM 1194 ! 1195 if (debugcol.ne.0) then 1196 ! 1197 do j=1,npoints,debugcol 1198 1199 !produce character output 1200 do ilev=1,nlev 1201 do ibox=1,ncol 1202 acc(ilev,ibox)=0 1203 enddo 1204 enddo 1205 1206 do ilev=1,nlev 1207 do ibox=1,ncol 1208 acc(ilev,ibox)=frac_out(j,ibox,ilev)*2 1209 if (levmatch(j,ibox) .eq. ilev) 1210 & acc(ilev,ibox)=acc(ilev,ibox)+1 1211 enddo 1212 enddo 1213 1214 !print test 1215 1216 write(ftn09,11) j 1217 11 format('ftn09.',i4.4) 1218 open(9, FILE=ftn09, FORM='FORMATTED') 1219 1220 write(9,'(a1)') ' ' 1221 write(9,'(10i5)') 1222 & (ilev,ilev=5,nlev,5) 1223 write(9,'(a1)') ' ' 1224 1225 do ibox=1,ncol 1226 write(9,'(40(a1),1x,40(a1))') 1227 & (cchar_realtops(acc(ilev,ibox)+1),ilev=1,nlev) 1228 & ,(cchar(acc(ilev,ibox)+1),ilev=1,nlev) 1229 end do 1230 close(9) 1231 1232 if (ncolprint.ne.0) then 1233 write(6,'(a1)') ' ' 1234 write(6,'(a2,1X,5(a7,1X),a50)') 1235 & 'ilev', 1236 & 'pfull','at', 1237 & 'cc*100','dem_s','dtau_s', 1238 & 'cchar' 1239 1240 ! do 4012 ilev=1,nlev 1241 ! write(6,'(60i2)') (box(i,ilev),i=1,ncolprint) 1242 ! write(6,'(i2,1X,5(f7.2,1X),50(a1))') 1243 ! & ilev, 1244 ! & pfull(j,ilev)/100.,at(j,ilev), 1245 ! & cc(j,ilev)*100.0,dem_s(j,ilev),dtau_s(j,ilev) 1246 ! & ,(cchar(acc(ilev,ibox)+1),ibox=1,ncolprint) 1247 !4012 continue 1248 write (6,'(a)') 'skt(j):' 1249 write (6,'(8f7.2)') skt(j) 1250 1251 write (6,'(8I7)') (ibox,ibox=1,ncolprint) 1252 1253 write (6,'(a)') 'tau:' 1254 write (6,'(8f7.2)') (tau(j,ibox),ibox=1,ncolprint) 1255 1256 write (6,'(a)') 'tb:' 1257 write (6,'(8f7.2)') (tb(j,ibox),ibox=1,ncolprint) 1258 1259 write (6,'(a)') 'ptop:' 1260 write (6,'(8f7.2)') (ptop(j,ibox),ibox=1,ncolprint) 1261 endif 1262 1263 enddo 1264 1265 end if 1266 1267 return 1268 end 1269 1270 1215 ! !print test 1216 1217 write(ftn09,11) j 1218 11 format('ftn09.',i4.4) 1219 open(9, FILE=ftn09, FORM='FORMATTED') 1220 1221 write(9,'(a1)') ' ' 1222 write(9,'(10i5)') & 1223 (ilev,ilev=5,nlev,5) 1224 write(9,'(a1)') ' ' 1225 1226 do ibox=1,ncol 1227 write(9,'(40(a1),1x,40(a1))') & 1228 (cchar_realtops(acc(ilev,ibox)+1),ilev=1,nlev) & 1229 ,(cchar(acc(ilev,ibox)+1),ilev=1,nlev) 1230 end do 1231 close(9) 1232 1233 if (ncolprint.ne.0) then 1234 write(6,'(a1)') ' ' 1235 write(6,'(a2,1X,5(a7,1X),a50)') & 1236 'ilev', & 1237 'pfull','at', & 1238 'cc*100','dem_s','dtau_s', & 1239 'cchar' 1240 1241 ! do 4012 ilev=1,nlev 1242 ! write(6,'(60i2)') (box(i,ilev),i=1,ncolprint) 1243 ! write(6,'(i2,1X,5(f7.2,1X),50(a1))') 1244 ! & ilev, 1245 ! & pfull(j,ilev)/100.,at(j,ilev), 1246 ! & cc(j,ilev)*100.0,dem_s(j,ilev),dtau_s(j,ilev) 1247 ! & ,(cchar(acc(ilev,ibox)+1),ibox=1,ncolprint) 1248 !4012 continue 1249 write (6,'(a)') 'skt(j):' 1250 write (6,'(8f7.2)') skt(j) 1251 1252 write (6,'(8I7)') (ibox,ibox=1,ncolprint) 1253 1254 write (6,'(a)') 'tau:' 1255 write (6,'(8f7.2)') (tau(j,ibox),ibox=1,ncolprint) 1256 1257 write (6,'(a)') 'tb:' 1258 write (6,'(8f7.2)') (tb(j,ibox),ibox=1,ncolprint) 1259 1260 write (6,'(a)') 'ptop:' 1261 write (6,'(8f7.2)') (ptop(j,ibox),ibox=1,ncolprint) 1262 endif 1263 1264 enddo 1265 1266 end if 1267 1268 return 1269 end subroutine icarus 1270 1271 -
LMDZ6/trunk/libf/phylmd/cosp/isccp_cloud_types.f90
r5247 r5248 1 1 ! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $ 2 2 ! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/icarus-scops-4.1-bsd/isccp_cloud_types.f $ 3 SUBROUTINE ISCCP_CLOUD_TYPES( 4 & debug,5 & debugcol,6 & npoints,7 & sunlit,8 & nlev,9 & ncol,10 & seed,11 & pfull,12 & phalf,13 & qv,14 & cc,15 & conv,16 & dtau_s,17 & dtau_c,18 & top_height,19 & top_height_direction,20 & overlap,21 & frac_out,22 & skt,23 & emsfc_lw,24 & at,25 & dem_s,26 & dem_c,27 & fq_isccp,28 & totalcldarea,29 & meanptop,30 & meantaucld,31 & meanalbedocld,32 & meantb,33 & meantbclr,34 & boxtau,35 & boxptop36 &)37 38 !$Id: isccp_cloud_types.f,v 4.0 2009/03/06 11:05:11 hadmw Exp $39 40 ! *****************************COPYRIGHT****************************41 ! (c) British Crown Copyright 2009, the Met Office.42 ! All rights reserved.43 ! 44 ! Redistribution and use in source and binary forms, with or without 45 ! modification, are permitted provided that the46 ! following conditions are met:47 ! 48 ! * Redistributions of source code must retain the above 49 ! copyright notice, this list of conditions and the following 50 !disclaimer.51 ! * Redistributions in binary form must reproduce the above 52 ! copyright notice, this list of conditions and the following 53 ! disclaimer in the documentation and/or other materials 54 !provided with the distribution.55 ! * Neither the name of the Met Office nor the names of its 56 !contributors may be used to endorse or promote products57 ! derived from this software without specific prior written 58 !permission.59 ! 60 ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 61 ! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 62 ! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 63 ! A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 64 ! OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 65 ! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 66 ! LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 67 ! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 68 ! THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 69 ! (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 70 ! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 71 ! 72 ! *****************************COPYRIGHT*******************************73 ! *****************************COPYRIGHT*******************************74 ! *****************************COPYRIGHT*******************************75 76 77 78 !NOTE: the maximum number of levels and columns is set by79 !the following parameter statement80 81 INTEGERncolprint82 83 !-----84 ! Input 85 !-----86 87 INTEGERnpoints ! number of model points in the horizontal88 INTEGERnlev ! number of model levels in column89 INTEGERncol ! number of subcolumns90 91 INTEGERsunlit(npoints) ! 1 for day points, 0 for night time92 93 INTEGERseed(npoints)94 95 96 97 98 99 100 101 102 103 REALpfull(npoints,nlev)104 105 106 107 108 REALphalf(npoints,nlev+1)109 110 111 112 113 REALqv(npoints,nlev)114 115 116 117 REAL cc(npoints,nlev)118 ! input cloud cover in each model level (fraction)119 120 121 122 REAL conv(npoints,nlev)123 124 ! level (fraction)125 126 127 128 REAL dtau_s(npoints,nlev)129 130 131 132 133 134 135 136 REAL dtau_c(npoints,nlev)137 138 139 140 141 INTEGERoverlap ! overlap type142 143 144 145 146 INTEGERtop_height ! 1 = adjust top height using both a computed147 148 149 150 151 152 153 154 155 156 157 158 159 160 INTEGERtop_height_direction ! direction for finding atmosphere pressure level161 162 163 164 165 166 167 168 169 ! with interpolated temperature equal to the radiance 170 171 ! 172 173 174 ! 1 = old setting: matches all versions of 175 176 177 ! 2 = default setting: for version numbers 4.0 and higher 178 !179 !The following input variables are used only if top_height = 1 or top_height = 3180 !181 REALskt(npoints) ! skin Temperature (K)182 REAL emsfc_lw ! 10.5 micron emissivity of surface (fraction)183 REALat(npoints,nlev) ! temperature in each model level (K)184 REALdem_s(npoints,nlev) ! 10.5 micron longwave emissivity of stratiform185 186 187 REALdem_c(npoints,nlev) ! 10.5 micron longwave emissivity of convective188 189 190 191 REALfrac_out(npoints,ncol,nlev) ! boxes gridbox divided up into192 193 194 195 196 197 198 !------199 !Output200 !------201 202 REALfq_isccp(npoints,7,7) ! the fraction of the model grid box covered by203 204 205 REALtotalcldarea(npoints) ! the fraction of model grid box columns206 207 208 209 210 211 212 213 ! The following three means are averages only over the cloudy areas with tau > isccp_taumin.214 ! If no clouds with tau > isccp_taumin are in grid box all three quantities should equal zero.215 216 REALmeanptop(npoints) ! mean cloud top pressure (mb) - linear averaging217 218 219 REAL meantaucld(npoints) ! mean optical thickness220 221 222 realmeanalbedocld(npoints) ! mean cloud albedo223 224 225 realmeantb(npoints) ! mean all-sky 10.5 micron brightness temperature226 227 realmeantbclr(npoints) ! mean clear-sky 10.5 micron brightness temperature228 229 REALboxtau(npoints,ncol) ! optical thickness in each column230 231 REALboxptop(npoints,ncol) ! cloud top pressure (mb) in each column232 233 234 !235 !------236 !Working variables added when program updated to mimic Mark Webb's PV-Wave code237 !------238 239 REAL dem(npoints,ncol),bb(npoints) ! working variables for 10.5 micron longwave240 241 242 243 REALptrop(npoints)244 REALattrop(npoints)245 REALattropmin (npoints)246 REALatmax(npoints)247 REALatmin(npoints)248 REALbtcmin(npoints)249 REALtransmax(npoints)250 251 INTEGERi,j,ilev,ibox,itrop(npoints)252 INTEGERipres(npoints)253 INTEGERitau(npoints),ilev2254 INTEGERacc(nlev,ncol)255 INTEGERmatch(npoints,nlev-1)256 INTEGERnmatch(npoints)257 INTEGERlevmatch(npoints,ncol)258 259 260 realfluxtop_clrsky(npoints),trans_layers_above_clrsky(npoints)261 realtaumin(npoints)262 realdem_wv(npoints,nlev), wtmair, wtmh20, Navo, grav, pstd, t0263 realpress(npoints), dpress(npoints), atmden(npoints)264 realrvh20(npoints), wk(npoints), rhoave(npoints)265 realrh20s(npoints), rfrgn(npoints)266 realtmpexp(npoints),tauwv(npoints)267 268 character*1cchar(6),cchar_realtops(6)269 integericycle270 REALtau(npoints,ncol)271 LOGICALbox_cloudy(npoints,ncol)272 REALtb(npoints,ncol)273 REALptop(npoints,ncol)274 REALemcld(npoints,ncol)275 REALfluxtop(npoints,ncol)276 REALtrans_layers_above(npoints,ncol)277 realisccp_taumin,fluxtopinit(npoints),tauir(npoints)278 REALalbedocld(npoints,ncol)279 realboxarea280 integerdebug ! set to non-zero value to print out inputs281 282 integerdebugcol ! set to non-zero value to print out column283 284 integerrangevec(npoints),rangeerror285 286 integerindex1(npoints),num1,jj,k1,k2287 realrec2p13,tauchk,logp,logp1,logp2,atd288 289 character*10ftn09290 291 292 293 294 295 !------ End duplicate definitions common to wrapper routine296 297 298 299 CALL SCOPS(300 & npoints,301 & nlev,302 & ncol,303 & seed,304 & cc,305 & conv,306 & overlap,307 & frac_out,308 & ncolprint309 &)310 311 CALL ICARUS(312 & debug,313 & debugcol,314 & npoints,315 & sunlit,316 & nlev,317 & ncol,318 & pfull,319 & phalf,320 & qv,321 & cc,322 & conv,323 & dtau_s,324 & dtau_c,325 & top_height,326 & top_height_direction,327 & overlap,328 & frac_out,329 & skt,330 & emsfc_lw,331 & at,332 & dem_s,333 & dem_c,334 & fq_isccp,335 & totalcldarea,336 & meanptop,337 & meantaucld,338 & meanalbedocld,339 & meantb,340 & meantbclr,341 & boxtau,342 & boxptop343 &)344 345 346 end 347 3 SUBROUTINE ISCCP_CLOUD_TYPES( & 4 debug, & 5 debugcol, & 6 npoints, & 7 sunlit, & 8 nlev, & 9 ncol, & 10 seed, & 11 pfull, & 12 phalf, & 13 qv, & 14 cc, & 15 conv, & 16 dtau_s, & 17 dtau_c, & 18 top_height, & 19 top_height_direction, & 20 overlap, & 21 frac_out, & 22 skt, & 23 emsfc_lw, & 24 at, & 25 dem_s, & 26 dem_c, & 27 fq_isccp, & 28 totalcldarea, & 29 meanptop, & 30 meantaucld, & 31 meanalbedocld, & 32 meantb, & 33 meantbclr, & 34 boxtau, & 35 boxptop & 36 ) 37 38 !$Id: isccp_cloud_types.f,v 4.0 2009/03/06 11:05:11 hadmw Exp $ 39 40 ! *****************************COPYRIGHT**************************** 41 ! (c) British Crown Copyright 2009, the Met Office. 42 ! All rights reserved. 43 ! 44 ! Redistribution and use in source and binary forms, with or without 45 ! modification, are permitted provided that the 46 ! following conditions are met: 47 ! 48 ! * Redistributions of source code must retain the above 49 ! copyright notice, this list of conditions and the following 50 ! disclaimer. 51 ! * Redistributions in binary form must reproduce the above 52 ! copyright notice, this list of conditions and the following 53 ! disclaimer in the documentation and/or other materials 54 ! provided with the distribution. 55 ! * Neither the name of the Met Office nor the names of its 56 ! contributors may be used to endorse or promote products 57 ! derived from this software without specific prior written 58 ! permission. 59 ! 60 ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 61 ! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 62 ! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 63 ! A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 64 ! OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 65 ! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 66 ! LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 67 ! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 68 ! THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 69 ! (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 70 ! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 71 ! 72 ! *****************************COPYRIGHT******************************* 73 ! *****************************COPYRIGHT******************************* 74 ! *****************************COPYRIGHT******************************* 75 76 implicit none 77 78 ! NOTE: the maximum number of levels and columns is set by 79 ! the following parameter statement 80 81 INTEGER :: ncolprint 82 83 ! ----- 84 ! Input 85 ! ----- 86 87 INTEGER :: npoints ! number of model points in the horizontal 88 INTEGER :: nlev ! number of model levels in column 89 INTEGER :: ncol ! number of subcolumns 90 91 INTEGER :: sunlit(npoints) ! 1 for day points, 0 for night time 92 93 INTEGER :: seed(npoints) 94 ! ! seed values for marsaglia random number generator 95 ! ! It is recommended that the seed is set 96 ! ! to a different value for each model 97 ! ! gridbox it is called on, as it is 98 ! ! possible that the choice of the same 99 ! ! seed value every time may introduce some 100 ! ! statistical bias in the results, particularly 101 ! ! for low values of NCOL. 102 103 REAL :: pfull(npoints,nlev) 104 ! ! pressure of full model levels (Pascals) 105 ! ! pfull(npoints,1) is top level of model 106 ! ! pfull(npoints,nlev) is bot of model 107 108 REAL :: phalf(npoints,nlev+1) 109 ! ! pressure of half model levels (Pascals) 110 ! ! phalf(npoints,1) is top of model 111 ! ! phalf(npoints,nlev+1) is the surface pressure 112 113 REAL :: qv(npoints,nlev) 114 ! ! water vapor specific humidity (kg vapor/ kg air) 115 ! ! on full model levels 116 117 REAL :: cc(npoints,nlev) 118 ! ! input cloud cover in each model level (fraction) 119 ! ! NOTE: This is the HORIZONTAL area of each 120 ! ! grid box covered by clouds 121 122 REAL :: conv(npoints,nlev) 123 ! ! input convective cloud cover in each model 124 ! ! level (fraction) 125 ! ! NOTE: This is the HORIZONTAL area of each 126 ! ! grid box covered by convective clouds 127 128 REAL :: dtau_s(npoints,nlev) 129 ! ! mean 0.67 micron optical depth of stratiform 130 ! ! clouds in each model level 131 ! ! NOTE: this the cloud optical depth of only the 132 ! ! cloudy part of the grid box, it is not weighted 133 ! ! with the 0 cloud optical depth of the clear 134 ! ! part of the grid box 135 136 REAL :: dtau_c(npoints,nlev) 137 ! ! mean 0.67 micron optical depth of convective 138 ! ! clouds in each 139 ! ! model level. Same note applies as in dtau_s. 140 141 INTEGER :: overlap ! overlap type 142 ! ! 1=max 143 ! ! 2=rand 144 ! ! 3=max/rand 145 146 INTEGER :: top_height ! 1 = adjust top height using both a computed 147 ! ! infrared brightness temperature and the visible 148 ! ! optical depth to adjust cloud top pressure. Note 149 ! ! that this calculation is most appropriate to compare 150 ! ! to ISCCP data during sunlit hours. 151 ! ! 2 = do not adjust top height, that is cloud top 152 ! ! pressure is the actual cloud top pressure 153 ! ! in the model 154 ! ! 3 = adjust top height using only the computed 155 ! ! infrared brightness temperature. Note that this 156 ! ! calculation is most appropriate to compare to ISCCP 157 ! ! IR only algortihm (i.e. you can compare to nighttime 158 ! ! ISCCP data with this option) 159 160 INTEGER :: top_height_direction ! direction for finding atmosphere pressure level 161 ! ! with interpolated temperature equal to the radiance 162 ! determined cloud-top temperature 163 ! 164 ! 1 = find the *lowest* altitude (highest pressure) level 165 ! with interpolated temperature equal to the radiance 166 ! determined cloud-top temperature 167 ! 168 ! 2 = find the *highest* altitude (lowest pressure) level 169 ! with interpolated temperature equal to the radiance 170 ! determined cloud-top temperature 171 ! 172 ! ONLY APPLICABLE IF top_height EQUALS 1 or 3 173 ! 174 ! 1 = old setting: matches all versions of 175 ! ISCCP simulator with versions numbers 3.5.1 and lower 176 ! 177 ! 2 = default setting: for version numbers 4.0 and higher 178 ! 179 ! The following input variables are used only if top_height = 1 or top_height = 3 180 ! 181 REAL :: skt(npoints) ! skin Temperature (K) 182 REAL :: emsfc_lw ! 10.5 micron emissivity of surface (fraction) 183 REAL :: at(npoints,nlev) ! temperature in each model level (K) 184 REAL :: dem_s(npoints,nlev) ! 10.5 micron longwave emissivity of stratiform 185 ! ! clouds in each 186 ! ! model level. Same note applies as in dtau_s. 187 REAL :: dem_c(npoints,nlev) ! 10.5 micron longwave emissivity of convective 188 ! ! clouds in each 189 ! ! model level. Same note applies as in dtau_s. 190 191 REAL :: frac_out(npoints,ncol,nlev) ! boxes gridbox divided up into 192 ! ! Equivalent of BOX in original version, but 193 ! ! indexed by column then row, rather than 194 ! ! by row then column 195 196 197 198 ! ------ 199 ! Output 200 ! ------ 201 202 REAL :: fq_isccp(npoints,7,7) ! the fraction of the model grid box covered by 203 ! ! each of the 49 ISCCP D level cloud types 204 205 REAL :: totalcldarea(npoints) ! the fraction of model grid box columns 206 ! ! with cloud somewhere in them. NOTE: This diagnostic 207 ! does not count model clouds with tau < isccp_taumin 208 ! ! Thus this diagnostic does not equal the sum over all entries of fq_isccp. 209 ! However, this diagnostic does equal the sum over entries of fq_isccp with 210 ! itau = 2:7 (omitting itau = 1) 211 212 213 ! ! The following three means are averages only over the cloudy areas with tau > isccp_taumin. 214 ! ! If no clouds with tau > isccp_taumin are in grid box all three quantities should equal zero. 215 216 REAL :: meanptop(npoints) ! mean cloud top pressure (mb) - linear averaging 217 ! ! in cloud top pressure. 218 219 REAL :: meantaucld(npoints) ! mean optical thickness 220 ! ! linear averaging in albedo performed. 221 222 real :: meanalbedocld(npoints) ! mean cloud albedo 223 ! ! linear averaging in albedo performed 224 225 real :: meantb(npoints) ! mean all-sky 10.5 micron brightness temperature 226 227 real :: meantbclr(npoints) ! mean clear-sky 10.5 micron brightness temperature 228 229 REAL :: boxtau(npoints,ncol) ! optical thickness in each column 230 231 REAL :: boxptop(npoints,ncol) ! cloud top pressure (mb) in each column 232 233 234 ! 235 ! ------ 236 ! Working variables added when program updated to mimic Mark Webb's PV-Wave code 237 ! ------ 238 239 REAL :: dem(npoints,ncol),bb(npoints) ! working variables for 10.5 micron longwave 240 ! ! emissivity in part of 241 ! ! gridbox under consideration 242 243 REAL :: ptrop(npoints) 244 REAL :: attrop(npoints) 245 REAL :: attropmin (npoints) 246 REAL :: atmax(npoints) 247 REAL :: atmin(npoints) 248 REAL :: btcmin(npoints) 249 REAL :: transmax(npoints) 250 251 INTEGER :: i,j,ilev,ibox,itrop(npoints) 252 INTEGER :: ipres(npoints) 253 INTEGER :: itau(npoints),ilev2 254 INTEGER :: acc(nlev,ncol) 255 INTEGER :: match(npoints,nlev-1) 256 INTEGER :: nmatch(npoints) 257 INTEGER :: levmatch(npoints,ncol) 258 259 ! !variables needed for water vapor continuum absorption 260 real :: fluxtop_clrsky(npoints),trans_layers_above_clrsky(npoints) 261 real :: taumin(npoints) 262 real :: dem_wv(npoints,nlev), wtmair, wtmh20, Navo, grav, pstd, t0 263 real :: press(npoints), dpress(npoints), atmden(npoints) 264 real :: rvh20(npoints), wk(npoints), rhoave(npoints) 265 real :: rh20s(npoints), rfrgn(npoints) 266 real :: tmpexp(npoints),tauwv(npoints) 267 268 character(len=1) :: cchar(6),cchar_realtops(6) 269 integer :: icycle 270 REAL :: tau(npoints,ncol) 271 LOGICAL :: box_cloudy(npoints,ncol) 272 REAL :: tb(npoints,ncol) 273 REAL :: ptop(npoints,ncol) 274 REAL :: emcld(npoints,ncol) 275 REAL :: fluxtop(npoints,ncol) 276 REAL :: trans_layers_above(npoints,ncol) 277 real :: isccp_taumin,fluxtopinit(npoints),tauir(npoints) 278 REAL :: albedocld(npoints,ncol) 279 real :: boxarea 280 integer :: debug ! set to non-zero value to print out inputs 281 ! ! with step debug 282 integer :: debugcol ! set to non-zero value to print out column 283 ! ! decomposition with step debugcol 284 integer :: rangevec(npoints),rangeerror 285 286 integer :: index1(npoints),num1,jj,k1,k2 287 real :: rec2p13,tauchk,logp,logp1,logp2,atd 288 289 character(len=10) :: ftn09 290 291 DATA isccp_taumin / 0.3 / 292 DATA cchar / ' ','-','1','+','I','+'/ 293 DATA cchar_realtops / ' ',' ','1','1','I','I'/ 294 295 ! ------ End duplicate definitions common to wrapper routine 296 297 ncolprint=0 298 299 CALL SCOPS( & 300 npoints, & 301 nlev, & 302 ncol, & 303 seed, & 304 cc, & 305 conv, & 306 overlap, & 307 frac_out, & 308 ncolprint & 309 ) 310 311 CALL ICARUS( & 312 debug, & 313 debugcol, & 314 npoints, & 315 sunlit, & 316 nlev, & 317 ncol, & 318 pfull, & 319 phalf, & 320 qv, & 321 cc, & 322 conv, & 323 dtau_s, & 324 dtau_c, & 325 top_height, & 326 top_height_direction, & 327 overlap, & 328 frac_out, & 329 skt, & 330 emsfc_lw, & 331 at, & 332 dem_s, & 333 dem_c, & 334 fq_isccp, & 335 totalcldarea, & 336 meanptop, & 337 meantaucld, & 338 meanalbedocld, & 339 meantb, & 340 meantbclr, & 341 boxtau, & 342 boxptop & 343 ) 344 345 return 346 end subroutine isccp_cloud_types 347 -
LMDZ6/trunk/libf/phylmd/cosp/pf_to_mr.f90
r5247 r5248 3 3 ! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $ 4 4 ! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/llnl/pf_to_mr.f $ 5 ! 6 ! Redistribution and use in source and binary forms, with or without modification, are permitted 5 ! 6 ! Redistribution and use in source and binary forms, with or without modification, are permitted 7 7 ! provided that the following conditions are met: 8 ! 9 ! * Redistributions of source code must retain the above copyright notice, this list10 ! 11 ! * Redistributions in binary form must reproduce the above copyright notice, this list12 ! of conditions and the following disclaimer in the documentation and/or other materials13 ! 14 ! * Neither the name of the Lawrence Livermore National Security Limited Liability Corporation15 ! nor the names of its contributors may be used to endorse or promote products derived from16 ! 17 ! 18 ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 19 ! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 20 ! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 21 ! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 22 ! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 23 ! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 24 ! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 8 ! 9 ! * Redistributions of source code must retain the above copyright notice, this list 10 ! of conditions and the following disclaimer. 11 ! * Redistributions in binary form must reproduce the above copyright notice, this list 12 ! of conditions and the following disclaimer in the documentation and/or other materials 13 ! provided with the distribution. 14 ! * Neither the name of the Lawrence Livermore National Security Limited Liability Corporation 15 ! nor the names of its contributors may be used to endorse or promote products derived from 16 ! this software without specific prior written permission. 17 ! 18 ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 19 ! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 20 ! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 21 ! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 22 ! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 23 ! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 24 ! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 25 25 ! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 26 27 subroutine pf_to_mr(npoints,nlev,ncol,rain_ls,snow_ls,grpl_ls, 28 & rain_cv,snow_cv,prec_frac,29 & p,t,mx_rain_ls,mx_snow_ls,mx_grpl_ls,30 &mx_rain_cv,mx_snow_cv)26 27 subroutine pf_to_mr(npoints,nlev,ncol,rain_ls,snow_ls,grpl_ls, & 28 rain_cv,snow_cv,prec_frac, & 29 p,t,mx_rain_ls,mx_snow_ls,mx_grpl_ls, & 30 mx_rain_cv,mx_snow_cv) 31 31 32 32 33 33 implicit none 34 34 35 INTEGERnpoints ! number of model points in the horizontal36 INTEGERnlev ! number of model levels in column37 INTEGERncol ! number of subcolumns35 INTEGER :: npoints ! number of model points in the horizontal 36 INTEGER :: nlev ! number of model levels in column 37 INTEGER :: ncol ! number of subcolumns 38 38 39 INTEGER j,ilev,ibox 40 41 REAL rain_ls(npoints,nlev),snow_ls(npoints,nlev) ! large-scale precip. flux 42 REAL grpl_ls(npoints,nlev) 43 REAL rain_cv(npoints,nlev),snow_cv(npoints,nlev) ! convective precip. flux 39 INTEGER :: j,ilev,ibox 44 40 45 REAL prec_frac(npoints,ncol,nlev) ! 0 -> clear sky 46 ! 1 -> LS precipitation 47 ! 2 -> CONV precipitation 48 ! 3 -> both 49 REAL mx_rain_ls(npoints,ncol,nlev),mx_snow_ls(npoints,ncol,nlev) 50 REAL mx_grpl_ls(npoints,ncol,nlev) 51 REAL mx_rain_cv(npoints,ncol,nlev),mx_snow_cv(npoints,ncol,nlev) 52 REAL p(npoints,nlev),t(npoints,nlev) 53 REAL ar,as,ag,br,bs,bg,nr,ns,ng,rho0,rhor,rhos,rhog,rho 54 REAL term1r,term1s,term1g,term2r,term2s,term2g,term3 55 REAL term4r_ls,term4s_ls,term4g_ls,term4r_cv,term4s_cv 56 REAL term1x2r,term1x2s,term1x2g,t123r,t123s,t123g 57 58 ! method from Khairoutdinov and Randall (2003 JAS) 41 REAL :: rain_ls(npoints,nlev),snow_ls(npoints,nlev) ! large-scale precip. flux 42 REAL :: grpl_ls(npoints,nlev) 43 REAL :: rain_cv(npoints,nlev),snow_cv(npoints,nlev) ! convective precip. flux 59 44 60 ! --- List of constants from Appendix B 61 ! Constant in fall speed formula 62 ar=842. 63 as=4.84 64 ag=94.5 65 ! Exponent in fall speed formula 66 br=0.8 67 bs=0.25 68 bg=0.5 69 ! Intercept parameter 70 nr=8.*1000.*1000. 71 ns=3.*1000.*1000. 72 ng=4.*1000.*1000. 73 ! Densities for air and hydrometeors 74 rho0=1.29 75 rhor=1000. 76 rhos=100. 77 rhog=400. 78 ! Term 1 of Eq. (A19). 79 term1r=ar*17.8379/6. 80 term1s=as*8.28508/6. 81 term1g=ag*11.6317/6. 82 ! Term 2 of Eq. (A19). 83 term2r=(3.14159265*rhor*nr)**(-br/4.) 84 term2s=(3.14159265*rhos*ns)**(-bs/4.) 85 term2g=(3.14159265*rhog*ng)**(-bg/4.) 86 87 term1x2r=term1r*term2r 88 term1x2s=term1s*term2s 89 term1x2g=term1g*term2g 90 do ilev=1,nlev 91 do j=1,npoints 92 rho=p(j,ilev)/(287.05*t(j,ilev)) 93 term3=(rho0/rho)**0.5 94 ! Term 4 of Eq. (A19). 95 t123r=term1x2r*term3 96 t123s=term1x2s*term3 97 t123g=term1x2g*term3 98 term4r_ls=rain_ls(j,ilev)/(t123r) 99 term4s_ls=snow_ls(j,ilev)/(t123s) 100 term4g_ls=grpl_ls(j,ilev)/(t123g) 101 term4r_cv=rain_cv(j,ilev)/(t123r) 102 term4s_cv=snow_cv(j,ilev)/(t123s) 103 do ibox=1,ncol 104 mx_rain_ls(j,ibox,ilev)=0. 105 mx_snow_ls(j,ibox,ilev)=0. 106 mx_grpl_ls(j,ibox,ilev)=0. 107 mx_rain_cv(j,ibox,ilev)=0. 108 mx_snow_cv(j,ibox,ilev)=0. 109 if ((prec_frac(j,ibox,ilev) .eq. 1.) .or. 110 & (prec_frac(j,ibox,ilev) .eq. 3.)) then 111 mx_rain_ls(j,ibox,ilev)= 112 & (term4r_ls**(1./(1.+br/4.)))/rho 113 mx_snow_ls(j,ibox,ilev)= 114 & (term4s_ls**(1./(1.+bs/4.)))/rho 115 mx_grpl_ls(j,ibox,ilev)= 116 & (term4g_ls**(1./(1.+bg/4.)))/rho 117 endif 118 if ((prec_frac(j,ibox,ilev) .eq. 2.) .or. 119 & (prec_frac(j,ibox,ilev) .eq. 3.)) then 120 mx_rain_cv(j,ibox,ilev)= 121 & (term4r_cv**(1./(1.+br/4.)))/rho 122 mx_snow_cv(j,ibox,ilev)= 123 & (term4s_cv**(1./(1.+bs/4.)))/rho 124 endif 125 enddo ! loop over ncol 126 enddo ! loop over npoints 127 enddo ! loop over nlev 128 129 end 45 REAL :: prec_frac(npoints,ncol,nlev) ! 0 -> clear sky 46 ! ! 1 -> LS precipitation 47 ! ! 2 -> CONV precipitation 48 ! ! 3 -> both 49 REAL :: mx_rain_ls(npoints,ncol,nlev),mx_snow_ls(npoints,ncol,nlev) 50 REAL :: mx_grpl_ls(npoints,ncol,nlev) 51 REAL :: mx_rain_cv(npoints,ncol,nlev),mx_snow_cv(npoints,ncol,nlev) 52 REAL :: p(npoints,nlev),t(npoints,nlev) 53 REAL :: ar,as,ag,br,bs,bg,nr,ns,ng,rho0,rhor,rhos,rhog,rho 54 REAL :: term1r,term1s,term1g,term2r,term2s,term2g,term3 55 REAL :: term4r_ls,term4s_ls,term4g_ls,term4r_cv,term4s_cv 56 REAL :: term1x2r,term1x2s,term1x2g,t123r,t123s,t123g 130 57 58 ! ! method from Khairoutdinov and Randall (2003 JAS) 59 60 ! ! --- List of constants from Appendix B 61 ! ! Constant in fall speed formula 62 ar=842. 63 as=4.84 64 ag=94.5 65 ! ! Exponent in fall speed formula 66 br=0.8 67 bs=0.25 68 bg=0.5 69 ! ! Intercept parameter 70 nr=8.*1000.*1000. 71 ns=3.*1000.*1000. 72 ng=4.*1000.*1000. 73 ! ! Densities for air and hydrometeors 74 rho0=1.29 75 rhor=1000. 76 rhos=100. 77 rhog=400. 78 ! ! Term 1 of Eq. (A19). 79 term1r=ar*17.8379/6. 80 term1s=as*8.28508/6. 81 term1g=ag*11.6317/6. 82 ! ! Term 2 of Eq. (A19). 83 term2r=(3.14159265*rhor*nr)**(-br/4.) 84 term2s=(3.14159265*rhos*ns)**(-bs/4.) 85 term2g=(3.14159265*rhog*ng)**(-bg/4.) 86 87 term1x2r=term1r*term2r 88 term1x2s=term1s*term2s 89 term1x2g=term1g*term2g 90 do ilev=1,nlev 91 do j=1,npoints 92 rho=p(j,ilev)/(287.05*t(j,ilev)) 93 term3=(rho0/rho)**0.5 94 ! ! Term 4 of Eq. (A19). 95 t123r=term1x2r*term3 96 t123s=term1x2s*term3 97 t123g=term1x2g*term3 98 term4r_ls=rain_ls(j,ilev)/(t123r) 99 term4s_ls=snow_ls(j,ilev)/(t123s) 100 term4g_ls=grpl_ls(j,ilev)/(t123g) 101 term4r_cv=rain_cv(j,ilev)/(t123r) 102 term4s_cv=snow_cv(j,ilev)/(t123s) 103 do ibox=1,ncol 104 mx_rain_ls(j,ibox,ilev)=0. 105 mx_snow_ls(j,ibox,ilev)=0. 106 mx_grpl_ls(j,ibox,ilev)=0. 107 mx_rain_cv(j,ibox,ilev)=0. 108 mx_snow_cv(j,ibox,ilev)=0. 109 if ((prec_frac(j,ibox,ilev) .eq. 1.) .or. & 110 (prec_frac(j,ibox,ilev) .eq. 3.)) then 111 mx_rain_ls(j,ibox,ilev)= & 112 (term4r_ls**(1./(1.+br/4.)))/rho 113 mx_snow_ls(j,ibox,ilev)= & 114 (term4s_ls**(1./(1.+bs/4.)))/rho 115 mx_grpl_ls(j,ibox,ilev)= & 116 (term4g_ls**(1./(1.+bg/4.)))/rho 117 endif 118 if ((prec_frac(j,ibox,ilev) .eq. 2.) .or. & 119 (prec_frac(j,ibox,ilev) .eq. 3.)) then 120 mx_rain_cv(j,ibox,ilev)= & 121 (term4r_cv**(1./(1.+br/4.)))/rho 122 mx_snow_cv(j,ibox,ilev)= & 123 (term4s_cv**(1./(1.+bs/4.)))/rho 124 endif 125 enddo ! loop over ncol 126 enddo ! loop over npoints 127 enddo ! loop over nlev 128 129 end subroutine pf_to_mr 130 -
LMDZ6/trunk/libf/phylmd/cosp/prec_scops.f90
r5247 r5248 3 3 ! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $ 4 4 ! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/llnl/prec_scops.f $ 5 ! 6 ! Redistribution and use in source and binary forms, with or without modification, are permitted 5 ! 6 ! Redistribution and use in source and binary forms, with or without modification, are permitted 7 7 ! provided that the following conditions are met: 8 ! 9 ! * Redistributions of source code must retain the above copyright notice, this list10 ! 11 ! * Redistributions in binary form must reproduce the above copyright notice, this list12 ! of conditions and the following disclaimer in the documentation and/or other materials13 ! 14 ! * Neither the name of the Lawrence Livermore National Security Limited Liability Corporation15 ! nor the names of its contributors may be used to endorse or promote products derived from16 ! 17 ! 18 ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 19 ! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 20 ! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 21 ! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 22 ! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 23 ! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 24 ! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 8 ! 9 ! * Redistributions of source code must retain the above copyright notice, this list 10 ! of conditions and the following disclaimer. 11 ! * Redistributions in binary form must reproduce the above copyright notice, this list 12 ! of conditions and the following disclaimer in the documentation and/or other materials 13 ! provided with the distribution. 14 ! * Neither the name of the Lawrence Livermore National Security Limited Liability Corporation 15 ! nor the names of its contributors may be used to endorse or promote products derived from 16 ! this software without specific prior written permission. 17 ! 18 ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 19 ! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 20 ! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 21 ! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 22 ! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 23 ! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 24 ! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 25 25 ! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 26 27 subroutine prec_scops(npoints,nlev,ncol,ls_p_rate,cv_p_rate, 28 & frac_out,prec_frac) 29 30 31 implicit none 32 33 INTEGER npoints ! number of model points in the horizontal 34 INTEGER nlev ! number of model levels in column 35 INTEGER ncol ! number of subcolumns 36 37 INTEGER i,j,ilev,ibox,cv_col 38 39 REAL ls_p_rate(npoints,nlev),cv_p_rate(npoints,nlev) 40 41 REAL frac_out(npoints,ncol,nlev) ! boxes gridbox divided up into 42 ! Equivalent of BOX in original version, but 43 ! indexed by column then row, rather than 44 ! by row then column 45 !TOA to SURFACE!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 46 REAL prec_frac(npoints,ncol,nlev) ! 0 -> clear sky 47 ! 1 -> LS precipitation 48 ! 2 -> CONV precipitation 49 ! 3 -> both 50 !TOA to SURFACE!!!!!!!!!!!!!!!!!! 51 52 INTEGER flag_ls, flag_cv 53 INTEGER frac_out_ls(npoints,ncol),frac_out_cv(npoints,ncol) !flag variables for 54 ! stratiform cloud and convective cloud in the vertical column 55 56 cv_col = 0.05*ncol 57 if (cv_col .eq. 0) cv_col=1 58 59 do ilev=1,nlev 60 do ibox=1,ncol 61 do j=1,npoints 62 prec_frac(j,ibox,ilev) = 0 63 enddo 64 enddo 26 27 subroutine prec_scops(npoints,nlev,ncol,ls_p_rate,cv_p_rate, & 28 frac_out,prec_frac) 29 30 31 implicit none 32 33 INTEGER :: npoints ! number of model points in the horizontal 34 INTEGER :: nlev ! number of model levels in column 35 INTEGER :: ncol ! number of subcolumns 36 37 INTEGER :: i,j,ilev,ibox,cv_col 38 39 REAL :: ls_p_rate(npoints,nlev),cv_p_rate(npoints,nlev) 40 41 REAL :: frac_out(npoints,ncol,nlev) ! boxes gridbox divided up into 42 ! ! Equivalent of BOX in original version, but 43 ! ! indexed by column then row, rather than 44 ! ! by row then column 45 ! !TOA to SURFACE!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 46 REAL :: prec_frac(npoints,ncol,nlev) ! 0 -> clear sky 47 ! ! 1 -> LS precipitation 48 ! ! 2 -> CONV precipitation 49 ! ! 3 -> both 50 ! !TOA to SURFACE!!!!!!!!!!!!!!!!!! 51 52 INTEGER :: flag_ls, flag_cv 53 INTEGER :: frac_out_ls(npoints,ncol),frac_out_cv(npoints,ncol) !flag variables for 54 ! ! stratiform cloud and convective cloud in the vertical column 55 56 cv_col = 0.05*ncol 57 if (cv_col .eq. 0) cv_col=1 58 59 do ilev=1,nlev 60 do ibox=1,ncol 61 do j=1,npoints 62 prec_frac(j,ibox,ilev) = 0 65 63 enddo 66 67 do j=1,npoints 68 do ibox=1,ncol 69 frac_out_ls(j,ibox)=0 70 frac_out_cv(j,ibox)=0 71 flag_ls=0 72 flag_cv=0 73 do ilev=1,nlev 74 if (frac_out(j,ibox,ilev) .eq. 1) then 75 flag_ls=1 76 endif 77 if (frac_out(j,ibox,ilev) .eq. 2) then 78 flag_cv=1 79 endif 80 enddo !loop over nlev 81 if (flag_ls .eq. 1) then 82 frac_out_ls(j,ibox)=1 83 endif 84 if (flag_cv .eq. 1) then 85 frac_out_cv(j,ibox)=1 86 endif 87 enddo ! loop over ncol 88 enddo ! loop over npoints 89 90 ! initialize the top layer 91 do j=1,npoints 92 flag_ls=0 93 flag_cv=0 94 95 if (ls_p_rate(j,1) .gt. 0.) then 96 do ibox=1,ncol ! possibility ONE 97 if (frac_out(j,ibox,1) .eq. 1) then 64 enddo 65 enddo 66 67 do j=1,npoints 68 do ibox=1,ncol 69 frac_out_ls(j,ibox)=0 70 frac_out_cv(j,ibox)=0 71 flag_ls=0 72 flag_cv=0 73 do ilev=1,nlev 74 if (frac_out(j,ibox,ilev) .eq. 1) then 75 flag_ls=1 76 endif 77 if (frac_out(j,ibox,ilev) .eq. 2) then 78 flag_cv=1 79 endif 80 enddo !loop over nlev 81 if (flag_ls .eq. 1) then 82 frac_out_ls(j,ibox)=1 83 endif 84 if (flag_cv .eq. 1) then 85 frac_out_cv(j,ibox)=1 86 endif 87 enddo ! loop over ncol 88 enddo ! loop over npoints 89 90 ! initialize the top layer 91 do j=1,npoints 92 flag_ls=0 93 flag_cv=0 94 95 if (ls_p_rate(j,1) .gt. 0.) then 96 do ibox=1,ncol ! possibility ONE 97 if (frac_out(j,ibox,1) .eq. 1) then 98 prec_frac(j,ibox,1) = 1 99 flag_ls=1 100 endif 101 enddo ! loop over ncol 102 if (flag_ls .eq. 0) then ! possibility THREE 103 do ibox=1,ncol 104 if (frac_out(j,ibox,2) .eq. 1) then 98 105 prec_frac(j,ibox,1) = 1 99 106 flag_ls=1 100 107 endif 101 108 enddo ! loop over ncol 102 if (flag_ls .eq. 0) then ! possibility THREE 103 do ibox=1,ncol 104 if (frac_out(j,ibox,2) .eq. 1) then 105 prec_frac(j,ibox,1) = 1 106 flag_ls=1 107 endif 108 enddo ! loop over ncol 109 endif 110 if (flag_ls .eq. 0) then ! possibility Four 111 do ibox=1,ncol 112 if (frac_out_ls(j,ibox) .eq. 1) then 113 prec_frac(j,ibox,1) = 1 114 flag_ls=1 115 endif 116 enddo ! loop over ncol 117 endif 118 if (flag_ls .eq. 0) then ! possibility Five 119 do ibox=1,ncol 120 ! prec_frac(j,1:ncol,1) = 1 109 endif 110 if (flag_ls .eq. 0) then ! possibility Four 111 do ibox=1,ncol 112 if (frac_out_ls(j,ibox) .eq. 1) then 121 113 prec_frac(j,ibox,1) = 1 122 enddo ! loop over ncol 123 endif 124 endif 125 ! There is large scale precipitation 126 127 if (cv_p_rate(j,1) .gt. 0.) then 128 do ibox=1,ncol ! possibility ONE 129 if (frac_out(j,ibox,1) .eq. 2) then 130 if (prec_frac(j,ibox,1) .eq. 0) then 114 flag_ls=1 115 endif 116 enddo ! loop over ncol 117 endif 118 if (flag_ls .eq. 0) then ! possibility Five 119 do ibox=1,ncol 120 ! ! prec_frac(j,1:ncol,1) = 1 121 prec_frac(j,ibox,1) = 1 122 enddo ! loop over ncol 123 endif 124 endif 125 ! ! There is large scale precipitation 126 127 if (cv_p_rate(j,1) .gt. 0.) then 128 do ibox=1,ncol ! possibility ONE 129 if (frac_out(j,ibox,1) .eq. 2) then 130 if (prec_frac(j,ibox,1) .eq. 0) then 131 prec_frac(j,ibox,1) = 2 132 else 133 prec_frac(j,ibox,1) = 3 134 endif 135 flag_cv=1 136 endif 137 enddo ! loop over ncol 138 if (flag_cv .eq. 0) then ! possibility THREE 139 do ibox=1,ncol 140 if (frac_out(j,ibox,2) .eq. 2) then 141 if (prec_frac(j,ibox,1) .eq. 0) then 131 142 prec_frac(j,ibox,1) = 2 132 else143 else 133 144 prec_frac(j,ibox,1) = 3 134 endif 135 flag_cv=1 145 endif 146 flag_cv=1 147 endif 148 enddo ! loop over ncol 149 endif 150 if (flag_cv .eq. 0) then ! possibility Four 151 do ibox=1,ncol 152 if (frac_out_cv(j,ibox) .eq. 1) then 153 if (prec_frac(j,ibox,1) .eq. 0) then 154 prec_frac(j,ibox,1) = 2 155 else 156 prec_frac(j,ibox,1) = 3 157 endif 158 flag_cv=1 159 endif 160 enddo ! loop over ncol 161 endif 162 if (flag_cv .eq. 0) then ! possibility Five 163 do ibox=1,cv_col 164 if (prec_frac(j,ibox,1) .eq. 0) then 165 prec_frac(j,ibox,1) = 2 166 else 167 prec_frac(j,ibox,1) = 3 168 endif 169 enddo !loop over cv_col 170 endif 171 endif 172 ! ! There is convective precipitation 173 174 enddo ! loop over npoints 175 ! end of initializing the top layer 176 177 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 178 179 ! working on the levels from top to surface 180 do ilev=2,nlev 181 do j=1,npoints 182 flag_ls=0 183 flag_cv=0 184 185 if (ls_p_rate(j,ilev) .gt. 0.) then 186 do ibox=1,ncol ! possibility ONE&TWO 187 if ((frac_out(j,ibox,ilev) .eq. 1) .or. & 188 ((prec_frac(j,ibox,ilev-1) .eq. 1) & 189 .or. (prec_frac(j,ibox,ilev-1) .eq. 3))) then 190 prec_frac(j,ibox,ilev) = 1 191 flag_ls=1 136 192 endif 137 enddo ! loop over ncol 138 if (flag_cv .eq. 0) then ! possibility THREE 139 do ibox=1,ncol 140 if (frac_out(j,ibox,2) .eq. 2) then 141 if (prec_frac(j,ibox,1) .eq. 0) then 142 prec_frac(j,ibox,1) = 2 143 else 144 prec_frac(j,ibox,1) = 3 145 endif 146 flag_cv=1 147 endif 148 enddo ! loop over ncol 149 endif 150 if (flag_cv .eq. 0) then ! possibility Four 151 do ibox=1,ncol 152 if (frac_out_cv(j,ibox) .eq. 1) then 153 if (prec_frac(j,ibox,1) .eq. 0) then 154 prec_frac(j,ibox,1) = 2 155 else 156 prec_frac(j,ibox,1) = 3 157 endif 158 flag_cv=1 159 endif 160 enddo ! loop over ncol 161 endif 162 if (flag_cv .eq. 0) then ! possibility Five 163 do ibox=1,cv_col 164 if (prec_frac(j,ibox,1) .eq. 0) then 165 prec_frac(j,ibox,1) = 2 166 else 167 prec_frac(j,ibox,1) = 3 168 endif 169 enddo !loop over cv_col 170 endif 171 endif 172 ! There is convective precipitation 173 174 enddo ! loop over npoints 175 ! end of initializing the top layer 176 177 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 178 179 ! working on the levels from top to surface 180 do ilev=2,nlev 181 do j=1,npoints 182 flag_ls=0 183 flag_cv=0 184 185 if (ls_p_rate(j,ilev) .gt. 0.) then 186 do ibox=1,ncol ! possibility ONE&TWO 187 if ((frac_out(j,ibox,ilev) .eq. 1) .or. 188 & ((prec_frac(j,ibox,ilev-1) .eq. 1) 189 & .or. (prec_frac(j,ibox,ilev-1) .eq. 3))) then 190 prec_frac(j,ibox,ilev) = 1 191 flag_ls=1 192 endif 193 enddo ! loop over ncol 194 if ((flag_ls .eq. 0) .and. (ilev .lt. nlev)) then ! possibility THREE 195 do ibox=1,ncol 196 if (frac_out(j,ibox,ilev+1) .eq. 1) then 197 prec_frac(j,ibox,ilev) = 1 198 flag_ls=1 199 endif 200 enddo ! loop over ncol 201 endif 202 if (flag_ls .eq. 0) then ! possibility Four 203 do ibox=1,ncol 204 if (frac_out_ls(j,ibox) .eq. 1) then 205 prec_frac(j,ibox,ilev) = 1 206 flag_ls=1 207 endif 208 enddo ! loop over ncol 209 endif 210 if (flag_ls .eq. 0) then ! possibility Five 211 do ibox=1,ncol 212 ! prec_frac(j,1:ncol,ilev) = 1 193 enddo ! loop over ncol 194 if ((flag_ls .eq. 0) .and. (ilev .lt. nlev)) then ! possibility THREE 195 do ibox=1,ncol 196 if (frac_out(j,ibox,ilev+1) .eq. 1) then 213 197 prec_frac(j,ibox,ilev) = 1 214 enddo ! loop over ncol 215 endif 216 endif ! There is large scale precipitation 217 218 if (cv_p_rate(j,ilev) .gt. 0.) then 219 do ibox=1,ncol ! possibility ONE&TWO 220 if ((frac_out(j,ibox,ilev) .eq. 2) .or. 221 & ((prec_frac(j,ibox,ilev-1) .eq. 2) 222 & .or. (prec_frac(j,ibox,ilev-1) .eq. 3))) then 198 flag_ls=1 199 endif 200 enddo ! loop over ncol 201 endif 202 if (flag_ls .eq. 0) then ! possibility Four 203 do ibox=1,ncol 204 if (frac_out_ls(j,ibox) .eq. 1) then 205 prec_frac(j,ibox,ilev) = 1 206 flag_ls=1 207 endif 208 enddo ! loop over ncol 209 endif 210 if (flag_ls .eq. 0) then ! possibility Five 211 do ibox=1,ncol 212 ! prec_frac(j,1:ncol,ilev) = 1 213 prec_frac(j,ibox,ilev) = 1 214 enddo ! loop over ncol 215 endif 216 endif ! There is large scale precipitation 217 218 if (cv_p_rate(j,ilev) .gt. 0.) then 219 do ibox=1,ncol ! possibility ONE&TWO 220 if ((frac_out(j,ibox,ilev) .eq. 2) .or. & 221 ((prec_frac(j,ibox,ilev-1) .eq. 2) & 222 .or. (prec_frac(j,ibox,ilev-1) .eq. 3))) then 223 if (prec_frac(j,ibox,ilev) .eq. 0) then 224 prec_frac(j,ibox,ilev) = 2 225 else 226 prec_frac(j,ibox,ilev) = 3 227 endif 228 flag_cv=1 229 endif 230 enddo ! loop over ncol 231 if ((flag_cv .eq. 0) .and. (ilev .lt. nlev)) then ! possibility THREE 232 do ibox=1,ncol 233 if (frac_out(j,ibox,ilev+1) .eq. 2) then 223 234 if (prec_frac(j,ibox,ilev) .eq. 0) then 224 prec_frac(j,ibox,ilev) = 2 225 else 226 prec_frac(j,ibox,ilev) = 3 227 endif 228 flag_cv=1 229 endif 230 enddo ! loop over ncol 231 if ((flag_cv .eq. 0) .and. (ilev .lt. nlev)) then ! possibility THREE 232 do ibox=1,ncol 233 if (frac_out(j,ibox,ilev+1) .eq. 2) then 234 if (prec_frac(j,ibox,ilev) .eq. 0) then 235 prec_frac(j,ibox,ilev) = 2 236 else 237 prec_frac(j,ibox,ilev) = 3 238 endif 239 flag_cv=1 240 endif 241 enddo ! loop over ncol 242 endif 243 if (flag_cv .eq. 0) then ! possibility Four 244 do ibox=1,ncol 245 if (frac_out_cv(j,ibox) .eq. 1) then 246 if (prec_frac(j,ibox,ilev) .eq. 0) then 247 prec_frac(j,ibox,ilev) = 2 248 else 249 prec_frac(j,ibox,ilev) = 3 250 endif 251 flag_cv=1 252 endif 253 enddo ! loop over ncol 254 endif 255 if (flag_cv .eq. 0) then ! possibility Five 256 do ibox=1,cv_col 257 if (prec_frac(j,ibox,ilev) .eq. 0) then 258 prec_frac(j,ibox,ilev) = 2 259 else 260 prec_frac(j,ibox,ilev) = 3 261 endif 262 enddo !loop over cv_col 263 endif 264 endif ! There is convective precipitation 265 266 enddo ! loop over npoints 267 enddo ! loop over nlev 268 269 end 270 235 prec_frac(j,ibox,ilev) = 2 236 else 237 prec_frac(j,ibox,ilev) = 3 238 endif 239 flag_cv=1 240 endif 241 enddo ! loop over ncol 242 endif 243 if (flag_cv .eq. 0) then ! possibility Four 244 do ibox=1,ncol 245 if (frac_out_cv(j,ibox) .eq. 1) then 246 if (prec_frac(j,ibox,ilev) .eq. 0) then 247 prec_frac(j,ibox,ilev) = 2 248 else 249 prec_frac(j,ibox,ilev) = 3 250 endif 251 flag_cv=1 252 endif 253 enddo ! loop over ncol 254 endif 255 if (flag_cv .eq. 0) then ! possibility Five 256 do ibox=1,cv_col 257 if (prec_frac(j,ibox,ilev) .eq. 0) then 258 prec_frac(j,ibox,ilev) = 2 259 else 260 prec_frac(j,ibox,ilev) = 3 261 endif 262 enddo !loop over cv_col 263 endif 264 endif ! There is convective precipitation 265 266 enddo ! loop over npoints 267 enddo ! loop over nlev 268 269 end subroutine prec_scops 270 -
LMDZ6/trunk/libf/phylmd/cosp/scops.f90
r5247 r5248 1 subroutine scops(npoints,nlev,ncol,seed,cc,conv, 2 & overlap,frac_out,ncolprint) 3 4 5 ! *****************************COPYRIGHT**************************** 6 ! (c) British Crown Copyright 2009, the Met Office. 7 ! All rights reserved. 8 ! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $ 9 ! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/icarus-scops-4.1-bsd/scops.f $ 10 ! 11 ! Redistribution and use in source and binary forms, with or without 12 ! modification, are permitted provided that the 13 ! following conditions are met: 14 ! 15 ! * Redistributions of source code must retain the above 16 ! copyright notice, this list of conditions and the following 17 ! disclaimer. 18 ! * Redistributions in binary form must reproduce the above 19 ! copyright notice, this list of conditions and the following 20 ! disclaimer in the documentation and/or other materials 21 ! provided with the distribution. 22 ! * Neither the name of the Met Office nor the names of its 23 ! contributors may be used to endorse or promote products 24 ! derived from this software without specific prior written 25 ! permission. 26 ! 27 ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 28 ! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 29 ! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 30 ! A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 31 ! OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 32 ! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 33 ! LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 34 ! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 35 ! THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 36 ! (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 37 ! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 38 ! 39 ! *****************************COPYRIGHT******************************* 40 ! *****************************COPYRIGHT******************************* 41 ! *****************************COPYRIGHT******************************* 42 43 implicit none 44 45 INTEGER npoints ! number of model points in the horizontal 46 INTEGER nlev ! number of model levels in column 47 INTEGER ncol ! number of subcolumns 48 49 50 INTEGER overlap ! overlap type 51 ! 1=max 52 ! 2=rand 53 ! 3=max/rand 54 REAL cc(npoints,nlev) 55 ! input cloud cover in each model level (fraction) 56 ! NOTE: This is the HORIZONTAL area of each 57 ! grid box covered by clouds 58 59 REAL conv(npoints,nlev) 60 ! input convective cloud cover in each model 61 ! level (fraction) 62 ! NOTE: This is the HORIZONTAL area of each 63 ! grid box covered by convective clouds 64 65 INTEGER i,j,ilev,ibox,ncolprint,ilev2 66 67 REAL frac_out(npoints,ncol,nlev) ! boxes gridbox divided up into 68 ! Equivalent of BOX in original version, but 69 ! indexed by column then row, rather than 70 ! by row then column 71 72 73 INTEGER seed(npoints) 74 ! seed values for marsaglia random number generator 75 ! It is recommended that the seed is set 76 ! to a different value for each model 77 ! gridbox it is called on, as it is 78 ! possible that the choice of the same 79 ! seed value every time may introduce some 80 ! statistical bias in the results, particularly 81 ! for low values of NCOL. 82 83 REAL tca(npoints,0:nlev) ! total cloud cover in each model level (fraction) 84 ! with extra layer of zeroes on top 85 ! in this version this just contains the values input 86 ! from cc but with an extra level 87 88 REAL threshold(npoints,ncol) ! pointer to position in gridbox 89 REAL maxocc(npoints,ncol) ! Flag for max overlapped conv cld 90 REAL maxosc(npoints,ncol) ! Flag for max overlapped strat cld 91 92 REAL boxpos(npoints,ncol) ! ordered pointer to position in gridbox 93 94 REAL threshold_min(npoints,ncol) ! minimum value to define range in with new threshold 95 ! is chosen 96 97 REAL ran(npoints) ! vector of random numbers 98 99 INTEGER irand,i2_16,huge32,overflow_32 ! variables for RNG 100 PARAMETER(huge32=2147483647) 101 i2_16=65536 102 103 do ibox=1,ncol 104 do j=1,npoints 105 boxpos(j,ibox)=(ibox-.5)/ncol 106 enddo 107 enddo 108 109 ! ---------------------------------------------------! 110 ! Initialise working variables 111 ! ---------------------------------------------------! 112 113 ! Initialised frac_out to zero 114 115 do ilev=1,nlev 116 do ibox=1,ncol 117 do j=1,npoints 118 frac_out(j,ibox,ilev)=0.0 1 subroutine scops(npoints,nlev,ncol,seed,cc,conv, & 2 overlap,frac_out,ncolprint) 3 4 5 ! *****************************COPYRIGHT**************************** 6 ! (c) British Crown Copyright 2009, the Met Office. 7 ! All rights reserved. 8 ! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $ 9 ! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/icarus-scops-4.1-bsd/scops.f $ 10 ! 11 ! Redistribution and use in source and binary forms, with or without 12 ! modification, are permitted provided that the 13 ! following conditions are met: 14 ! 15 ! * Redistributions of source code must retain the above 16 ! copyright notice, this list of conditions and the following 17 ! disclaimer. 18 ! * Redistributions in binary form must reproduce the above 19 ! copyright notice, this list of conditions and the following 20 ! disclaimer in the documentation and/or other materials 21 ! provided with the distribution. 22 ! * Neither the name of the Met Office nor the names of its 23 ! contributors may be used to endorse or promote products 24 ! derived from this software without specific prior written 25 ! permission. 26 ! 27 ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 28 ! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 29 ! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 30 ! A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 31 ! OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 32 ! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 33 ! LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 34 ! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 35 ! THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 36 ! (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 37 ! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 38 ! 39 ! *****************************COPYRIGHT******************************* 40 ! *****************************COPYRIGHT******************************* 41 ! *****************************COPYRIGHT******************************* 42 43 implicit none 44 45 INTEGER :: npoints ! number of model points in the horizontal 46 INTEGER :: nlev ! number of model levels in column 47 INTEGER :: ncol ! number of subcolumns 48 49 50 INTEGER :: overlap ! overlap type 51 ! ! 1=max 52 ! ! 2=rand 53 ! ! 3=max/rand 54 REAL :: cc(npoints,nlev) 55 ! ! input cloud cover in each model level (fraction) 56 ! ! NOTE: This is the HORIZONTAL area of each 57 ! ! grid box covered by clouds 58 59 REAL :: conv(npoints,nlev) 60 ! ! input convective cloud cover in each model 61 ! ! level (fraction) 62 ! ! NOTE: This is the HORIZONTAL area of each 63 ! ! grid box covered by convective clouds 64 65 INTEGER :: i,j,ilev,ibox,ncolprint,ilev2 66 67 REAL :: frac_out(npoints,ncol,nlev) ! boxes gridbox divided up into 68 ! ! Equivalent of BOX in original version, but 69 ! ! indexed by column then row, rather than 70 ! ! by row then column 71 72 73 INTEGER :: seed(npoints) 74 ! ! seed values for marsaglia random number generator 75 ! ! It is recommended that the seed is set 76 ! ! to a different value for each model 77 ! ! gridbox it is called on, as it is 78 ! ! possible that the choice of the same 79 ! ! seed value every time may introduce some 80 ! ! statistical bias in the results, particularly 81 ! ! for low values of NCOL. 82 83 REAL :: tca(npoints,0:nlev) ! total cloud cover in each model level (fraction) 84 ! ! with extra layer of zeroes on top 85 ! ! in this version this just contains the values input 86 ! ! from cc but with an extra level 87 88 REAL :: threshold(npoints,ncol) ! pointer to position in gridbox 89 REAL :: maxocc(npoints,ncol) ! Flag for max overlapped conv cld 90 REAL :: maxosc(npoints,ncol) ! Flag for max overlapped strat cld 91 92 REAL :: boxpos(npoints,ncol) ! ordered pointer to position in gridbox 93 94 REAL :: threshold_min(npoints,ncol) ! minimum value to define range in with new threshold 95 ! ! is chosen 96 97 REAL :: ran(npoints) ! vector of random numbers 98 99 INTEGER :: irand,i2_16,huge32,overflow_32 ! variables for RNG 100 PARAMETER(huge32=2147483647) 101 i2_16=65536 102 103 do ibox=1,ncol 104 do j=1,npoints 105 boxpos(j,ibox)=(ibox-.5)/ncol 106 enddo 107 enddo 108 109 ! ---------------------------------------------------! 110 ! Initialise working variables 111 ! ---------------------------------------------------! 112 113 ! Initialised frac_out to zero 114 115 do ilev=1,nlev 116 do ibox=1,ncol 117 do j=1,npoints 118 frac_out(j,ibox,ilev)=0.0 119 enddo 120 enddo 121 enddo 122 123 ! assign 2d tca array using 1d input array cc 124 125 do j=1,npoints 126 tca(j,0)=0 127 enddo 128 129 do ilev=1,nlev 130 do j=1,npoints 131 tca(j,ilev)=cc(j,ilev) 132 enddo 133 enddo 134 135 if (ncolprint.ne.0) then 136 write (6,'(a)') 'frac_out_pp_rev:' 137 do j=1,npoints,1000 138 write(6,'(a10)') 'j=' 139 write(6,'(8I10)') j 140 write (6,'(8f5.2)') & 141 ((frac_out(j,ibox,ilev),ibox=1,ncolprint),ilev=1,nlev) 142 143 enddo 144 write (6,'(a)') 'ncol:' 145 write (6,'(I3)') ncol 146 endif 147 if (ncolprint.ne.0) then 148 write (6,'(a)') 'last_frac_pp:' 149 do j=1,npoints,1000 150 write(6,'(a10)') 'j=' 151 write(6,'(8I10)') j 152 write (6,'(8f5.2)') (tca(j,0)) 153 enddo 154 endif 155 156 ! ---------------------------------------------------! 157 ! ALLOCATE CLOUD INTO BOXES, FOR NCOLUMNS, NLEVELS 158 ! frac_out is the array that contains the information 159 ! where 0 is no cloud, 1 is a stratiform cloud and 2 is a 160 ! convective cloud 161 162 ! !loop over vertical levels 163 DO ilev = 1,nlev 164 165 ! Initialise threshold 166 167 IF (ilev.eq.1) then 168 ! ! If max overlap 169 IF (overlap.eq.1) then 170 ! ! select pixels spread evenly 171 ! ! across the gridbox 172 DO ibox=1,ncol 173 do j=1,npoints 174 threshold(j,ibox)=boxpos(j,ibox) 175 enddo 119 176 enddo 120 enddo 121 enddo 122 123 ! assign 2d tca array using 1d input array cc 124 125 do j=1,npoints 126 tca(j,0)=0 127 enddo 128 129 do ilev=1,nlev 130 do j=1,npoints 131 tca(j,ilev)=cc(j,ilev) 132 enddo 133 enddo 134 135 if (ncolprint.ne.0) then 136 write (6,'(a)') 'frac_out_pp_rev:' 137 do j=1,npoints,1000 138 write(6,'(a10)') 'j=' 139 write(6,'(8I10)') j 140 write (6,'(8f5.2)') 141 & ((frac_out(j,ibox,ilev),ibox=1,ncolprint),ilev=1,nlev) 142 177 ELSE 178 DO ibox=1,ncol 179 include 'congvec.h' 180 ! ! select random pixels from the non-convective 181 ! ! part the gridbox ( some will be converted into 182 ! ! convective pixels below ) 183 do j=1,npoints 184 threshold(j,ibox)= & 185 conv(j,ilev)+(1-conv(j,ilev))*ran(j) 186 enddo 143 187 enddo 144 write (6,'(a)') 'ncol:'145 write (6,'(I3)') ncol146 endif147 if (ncolprint.ne.0) then148 write (6,'(a)') 'last_frac_pp:'149 do j=1,npoints,1000150 write(6,'(a10)') 'j='151 write(6,'(8I10)') j152 write (6,'(8f5.2)') (tca(j,0))153 enddo154 endif155 156 ! ---------------------------------------------------!157 ! ALLOCATE CLOUD INTO BOXES, FOR NCOLUMNS, NLEVELS158 ! frac_out is the array that contains the information159 ! where 0 is no cloud, 1 is a stratiform cloud and 2 is a160 ! convective cloud161 162 !loop over vertical levels163 DO 200 ilev = 1,nlev164 165 ! Initialise threshold166 167 IF (ilev.eq.1) then168 ! If max overlap169 IF (overlap.eq.1) then170 ! select pixels spread evenly171 ! across the gridbox172 DO ibox=1,ncol173 do j=1,npoints174 threshold(j,ibox)=boxpos(j,ibox)175 enddo176 enddo177 ELSE178 DO ibox=1,ncol179 include 'congvec.h'180 ! select random pixels from the non-convective181 ! part the gridbox ( some will be converted into182 ! convective pixels below )183 do j=1,npoints184 threshold(j,ibox)=185 & conv(j,ilev)+(1-conv(j,ilev))*ran(j)186 enddo187 enddo188 ENDIF189 IF (ncolprint.ne.0) then190 write (6,'(a)') 'threshold_nsf2:'191 do j=1,npoints,1000192 write(6,'(a10)') 'j='193 write(6,'(8I10)') j194 write (6,'(8f5.2)') (threshold(j,ibox),ibox=1,ncolprint)195 enddo196 ENDIF197 188 ENDIF 198 199 189 IF (ncolprint.ne.0) then 200 write (6,'(a)') 'ilev:' 201 write (6,'(I2)') ilev 202 ENDIF 203 204 DO ibox=1,ncol 205 206 ! All versions 207 do j=1,npoints 208 if (boxpos(j,ibox).le.conv(j,ilev)) then 209 maxocc(j,ibox) = 1 210 else 211 maxocc(j,ibox) = 0 212 end if 213 enddo 214 215 ! Max overlap 216 if (overlap.eq.1) then 217 do j=1,npoints 218 threshold_min(j,ibox)=conv(j,ilev) 219 maxosc(j,ibox)=1 220 enddo 221 endif 222 223 ! Random overlap 224 if (overlap.eq.2) then 225 do j=1,npoints 226 threshold_min(j,ibox)=conv(j,ilev) 227 maxosc(j,ibox)=0 228 enddo 229 endif 230 231 ! Max/Random overlap 232 if (overlap.eq.3) then 233 do j=1,npoints 234 threshold_min(j,ibox)=max(conv(j,ilev), 235 & min(tca(j,ilev-1),tca(j,ilev))) 236 if (threshold(j,ibox) 237 & .lt.min(tca(j,ilev-1),tca(j,ilev)) 238 & .and.(threshold(j,ibox).gt.conv(j,ilev))) then 239 maxosc(j,ibox)= 1 240 else 241 maxosc(j,ibox)= 0 242 end if 243 enddo 244 endif 245 246 ! Reset threshold 247 248 include 'congvec.h' 249 250 do j=1,npoints 251 threshold(j,ibox)= 252 !if max overlapped conv cloud 253 & maxocc(j,ibox) * ( 254 & boxpos(j,ibox) 255 & ) + 256 !else 257 & (1-maxocc(j,ibox)) * ( 258 !if max overlapped strat cloud 259 & (maxosc(j,ibox)) * ( 260 !threshold=boxpos 261 & threshold(j,ibox) 262 & ) + 263 !else 264 & (1-maxosc(j,ibox)) * ( 265 !threshold_min=random[thrmin,1] 266 & threshold_min(j,ibox)+ 267 & (1-threshold_min(j,ibox))*ran(j) 268 & ) 269 & ) 270 enddo 271 272 ENDDO ! ibox 273 274 ! Fill frac_out with 1's where tca is greater than the threshold 275 276 DO ibox=1,ncol 277 do j=1,npoints 278 if (tca(j,ilev).gt.threshold(j,ibox)) then 279 frac_out(j,ibox,ilev)=1 280 else 281 frac_out(j,ibox,ilev)=0 282 end if 283 enddo 284 ENDDO 285 286 ! Code to partition boxes into startiform and convective parts 287 ! goes here 288 289 DO ibox=1,ncol 290 do j=1,npoints 291 if (threshold(j,ibox).le.conv(j,ilev)) then 292 ! = 2 IF threshold le conv(j) 293 frac_out(j,ibox,ilev) = 2 294 else 295 ! = the same IF NOT threshold le conv(j) 296 frac_out(j,ibox,ilev) = frac_out(j,ibox,ilev) 297 end if 298 enddo 299 ENDDO 300 301 ! Set last_frac to tca at this level, so as to be tca 302 ! from last level next time round 303 304 if (ncolprint.ne.0) then 305 306 do j=1,npoints ,1000 190 write (6,'(a)') 'threshold_nsf2:' 191 do j=1,npoints,1000 307 192 write(6,'(a10)') 'j=' 308 193 write(6,'(8I10)') j 309 write (6,'(a)') 'last_frac:'310 write (6,'(8f5.2)') (tca(j,ilev-1))311 312 write (6,'(a)') 'conv:'313 write (6,'(8f5.2)') (conv(j,ilev),ibox=1,ncolprint)314 315 write (6,'(a)') 'max_overlap_cc:'316 write (6,'(8f5.2)') (maxocc(j,ibox),ibox=1,ncolprint)317 318 write (6,'(a)') 'max_overlap_sc:'319 write (6,'(8f5.2)') (maxosc(j,ibox),ibox=1,ncolprint)320 321 write (6,'(a)') 'threshold_min_nsf2:'322 write (6,'(8f5.2)') (threshold_min(j,ibox),ibox=1,ncolprint)323 324 write (6,'(a)') 'threshold_nsf2:'325 194 write (6,'(8f5.2)') (threshold(j,ibox),ibox=1,ncolprint) 326 327 write (6,'(a)') 'frac_out_pp_rev:' 328 write (6,'(8f5.2)') 329 & ((frac_out(j,ibox,ilev2),ibox=1,ncolprint),ilev2=1,nlev) 330 enddo 331 endif 332 333 200 CONTINUE !loop over nlev 334 335 336 end 337 195 enddo 196 ENDIF 197 ENDIF 198 199 IF (ncolprint.ne.0) then 200 write (6,'(a)') 'ilev:' 201 write (6,'(I2)') ilev 202 ENDIF 203 204 DO ibox=1,ncol 205 206 ! ! All versions 207 do j=1,npoints 208 if (boxpos(j,ibox).le.conv(j,ilev)) then 209 maxocc(j,ibox) = 1 210 else 211 maxocc(j,ibox) = 0 212 end if 213 enddo 214 215 ! ! Max overlap 216 if (overlap.eq.1) then 217 do j=1,npoints 218 threshold_min(j,ibox)=conv(j,ilev) 219 maxosc(j,ibox)=1 220 enddo 221 endif 222 223 ! ! Random overlap 224 if (overlap.eq.2) then 225 do j=1,npoints 226 threshold_min(j,ibox)=conv(j,ilev) 227 maxosc(j,ibox)=0 228 enddo 229 endif 230 231 ! ! Max/Random overlap 232 if (overlap.eq.3) then 233 do j=1,npoints 234 threshold_min(j,ibox)=max(conv(j,ilev), & 235 min(tca(j,ilev-1),tca(j,ilev))) 236 if (threshold(j,ibox) & 237 .lt.min(tca(j,ilev-1),tca(j,ilev)) & 238 .and.(threshold(j,ibox).gt.conv(j,ilev))) then 239 maxosc(j,ibox)= 1 240 else 241 maxosc(j,ibox)= 0 242 end if 243 enddo 244 endif 245 246 ! ! Reset threshold 247 248 include 'congvec.h' 249 250 do j=1,npoints 251 threshold(j,ibox)= & 252 ! !if max overlapped conv cloud 253 maxocc(j,ibox) * ( & 254 boxpos(j,ibox) & 255 ) + & 256 ! !else 257 (1-maxocc(j,ibox)) * ( & 258 ! !if max overlapped strat cloud 259 (maxosc(j,ibox)) * ( & 260 ! !threshold=boxpos 261 threshold(j,ibox) & 262 ) + & 263 ! !else 264 (1-maxosc(j,ibox)) * ( & 265 ! !threshold_min=random[thrmin,1] 266 threshold_min(j,ibox)+ & 267 (1-threshold_min(j,ibox))*ran(j) & 268 ) & 269 ) 270 enddo 271 272 ENDDO ! ibox 273 274 ! Fill frac_out with 1's where tca is greater than the threshold 275 276 DO ibox=1,ncol 277 do j=1,npoints 278 if (tca(j,ilev).gt.threshold(j,ibox)) then 279 frac_out(j,ibox,ilev)=1 280 else 281 frac_out(j,ibox,ilev)=0 282 end if 283 enddo 284 ENDDO 285 286 ! Code to partition boxes into startiform and convective parts 287 ! goes here 288 289 DO ibox=1,ncol 290 do j=1,npoints 291 if (threshold(j,ibox).le.conv(j,ilev)) then 292 ! ! = 2 IF threshold le conv(j) 293 frac_out(j,ibox,ilev) = 2 294 else 295 ! ! = the same IF NOT threshold le conv(j) 296 frac_out(j,ibox,ilev) = frac_out(j,ibox,ilev) 297 end if 298 enddo 299 ENDDO 300 301 ! Set last_frac to tca at this level, so as to be tca 302 ! from last level next time round 303 304 if (ncolprint.ne.0) then 305 306 do j=1,npoints ,1000 307 write(6,'(a10)') 'j=' 308 write(6,'(8I10)') j 309 write (6,'(a)') 'last_frac:' 310 write (6,'(8f5.2)') (tca(j,ilev-1)) 311 312 write (6,'(a)') 'conv:' 313 write (6,'(8f5.2)') (conv(j,ilev),ibox=1,ncolprint) 314 315 write (6,'(a)') 'max_overlap_cc:' 316 write (6,'(8f5.2)') (maxocc(j,ibox),ibox=1,ncolprint) 317 318 write (6,'(a)') 'max_overlap_sc:' 319 write (6,'(8f5.2)') (maxosc(j,ibox),ibox=1,ncolprint) 320 321 write (6,'(a)') 'threshold_min_nsf2:' 322 write (6,'(8f5.2)') (threshold_min(j,ibox),ibox=1,ncolprint) 323 324 write (6,'(a)') 'threshold_nsf2:' 325 write (6,'(8f5.2)') (threshold(j,ibox),ibox=1,ncolprint) 326 327 write (6,'(a)') 'frac_out_pp_rev:' 328 write (6,'(8f5.2)') & 329 ((frac_out(j,ibox,ilev2),ibox=1,ncolprint),ilev2=1,nlev) 330 enddo 331 endif 332 333 END DO 334 335 336 end subroutine scops 337
Note: See TracChangeset
for help on using the changeset viewer.
