Changeset 5086
- Timestamp:
- Jul 19, 2024, 7:54:50 PM (7 weeks ago)
- Location:
- LMDZ6/branches/Amaury_dev
- Files:
-
- 130 edited
Legend:
- Unmodified
- Added
- Removed
-
LMDZ6/branches/Amaury_dev/libf/dyn3d/advect.F
r2622 r5086 57 57 deuxjour = 2. * daysec 58 58 59 DO 1ij = 1, ip1jmp159 DO ij = 1, ip1jmp1 60 60 unsaire2(ij) = unsaire(ij) * unsaire(ij) 61 1 CONTINUE61 END DO 62 62 END IF 63 63 … … 100 100 101 101 c 102 DO 20l = 1, llmm1102 DO l = 1, llmm1 103 103 104 104 105 105 c ...... calcul de - w/2. au niveau l+1 ....... 106 106 107 DO 5ij = 1, ip1jmp1107 DO ij = 1, ip1jmp1 108 108 wsur2( ij ) = - 0.5 * w( ij,l+1 ) 109 5 CONTINUE109 END DO 110 110 111 111 112 112 c ..................... calcul pour du .................. 113 113 114 DO 6ij = iip2 ,ip1jm-1114 DO ij = iip2 ,ip1jm-1 115 115 ww = wsur2 ( ij ) + wsur2( ij+1 ) 116 116 uu = 0.5 * ( ucov(ij,l) + ucov(ij,l+1) ) 117 117 du(ij,l) = du(ij,l) - ww * ( uu - uav(ij, l ) )/massebx(ij, l ) 118 118 du(ij,l+1)= du(ij,l+1) + ww * ( uu - uav(ij,l+1) )/massebx(ij,l+1) 119 6 CONTINUE119 END DO 120 120 121 121 c ..... correction pour du(iip1,j,l) ........ … … 123 123 124 124 CDIR$ IVDEP 125 DO 7ij = iip1 +iip1, ip1jm, iip1125 DO ij = iip1 +iip1, ip1jm, iip1 126 126 du( ij, l ) = du( ij -iim, l ) 127 127 du( ij,l+1 ) = du( ij -iim,l+1 ) 128 7 CONTINUE128 END DO 129 129 130 130 c ................. calcul pour dv ..................... 131 131 132 DO 8ij = 1, ip1jm132 DO ij = 1, ip1jm 133 133 ww = wsur2( ij+iip1 ) + wsur2( ij ) 134 134 vv = 0.5 * ( vcov(ij,l) + vcov(ij,l+1) ) 135 135 dv(ij,l) = dv(ij, l ) - ww * (vv - vav(ij, l ) )/masseby(ij, l ) 136 136 dv(ij,l+1)= dv(ij,l+1) + ww * (vv - vav(ij,l+1) )/masseby(ij,l+1) 137 8 CONTINUE137 END DO 138 138 139 139 c … … 147 147 c ............... 148 148 149 DO 15ij = 1, ip1jmp1149 DO ij = 1, ip1jmp1 150 150 ww = wsur2(ij) * (teta(ij,l) + teta(ij,l+1) ) 151 151 dteta(ij, l ) = dteta(ij, l ) - ww 152 152 dteta(ij,l+1) = dteta(ij,l+1) + ww 153 15 CONTINUE153 END DO 154 154 155 155 IF( conser) THEN 156 DO 17ij = 1,ip1jmp1156 DO ij = 1,ip1jmp1 157 157 ge(ij) = wsur2(ij) * wsur2(ij) * unsaire2(ij) 158 17 CONTINUE158 END DO 159 159 gt = SSUM( ip1jmp1,ge,1 ) 160 160 gtot(l) = deuxjour * SQRT( gt/ip1jmp1 ) 161 161 END IF 162 162 163 20 CONTINUE163 END DO 164 164 165 165 RETURN -
LMDZ6/branches/Amaury_dev/libf/dyn3d/dteta1.F
r2603 r5086 32 32 c 33 33 34 DO 5l = 1,llm34 DO l = 1,llm 35 35 36 DO 1ij = iip2, ip1jm - 136 DO ij = iip2, ip1jm - 1 37 37 hbxu(ij,l) = pbaru(ij,l) * 0.5 * ( teta(ij,l) + teta(ij+1,l) ) 38 1 CONTINUE38 END DO 39 39 40 40 c .... correction pour hbxu(iip1,j,l) ..... … … 42 42 43 43 CDIR$ IVDEP 44 DO 2ij = iip1+ iip1, ip1jm, iip144 DO ij = iip1+ iip1, ip1jm, iip1 45 45 hbxu( ij, l ) = hbxu( ij - iim, l ) 46 2 CONTINUE46 END DO 47 47 48 48 49 DO 3ij = 1,ip1jm49 DO ij = 1,ip1jm 50 50 hbyv(ij,l)= pbarv(ij, l)* 0.5 * ( teta(ij, l)+ teta(ij +iip1,l) ) 51 3 CONTINUE51 END DO 52 52 53 5 CONTINUE53 END DO 54 54 55 55 -
LMDZ6/branches/Amaury_dev/libf/dyn3d/dudv1.F
r1907 r5086 27 27 c 28 28 c 29 DO 10l = 1,llm29 DO l = 1,llm 30 30 c 31 DO 2ij = iip2, ip1jm - 131 DO ij = iip2, ip1jm - 1 32 32 du( ij,l ) = 0.125 *( vorpot(ij-iip1, l) + vorpot( ij, l) ) * 33 33 * ( pbarv(ij-iip1, l) + pbarv(ij-iim, l) + 34 34 * pbarv( ij , l) + pbarv(ij+ 1 , l) ) 35 2 CONTINUE35 END DO 36 36 c 37 DO 3ij = 1, ip1jm - 137 DO ij = 1, ip1jm - 1 38 38 dv( ij+1,l ) = - 0.125 *( vorpot(ij, l) + vorpot(ij+1, l) ) * 39 39 * ( pbaru(ij, l) + pbaru(ij+1 , l) + 40 40 * pbaru(ij+iip1, l) + pbaru(ij+iip2, l) ) 41 3 CONTINUE41 END DO 42 42 c 43 43 c .... correction pour dv( 1,j,l ) ..... … … 45 45 c 46 46 CDIR$ IVDEP 47 DO 4ij = 1, ip1jm, iip147 DO ij = 1, ip1jm, iip1 48 48 dv( ij,l ) = dv( ij + iim, l ) 49 4 CONTINUE49 END DO 50 50 c 51 10 CONTINUE51 END DO 52 52 RETURN 53 53 END -
LMDZ6/branches/Amaury_dev/libf/dyn3d/dudv2.F
r2600 r5086 34 34 c 35 35 c 36 DO 5l = 1,llm36 DO l = 1,llm 37 37 c 38 DO 2ij = iip2, ip1jm - 138 DO ij = iip2, ip1jm - 1 39 39 du(ij,l) = du(ij,l) + 0.5* ( teta( ij,l ) + teta( ij+1,l ) ) * 40 40 * ( pkf( ij,l ) - pkf(ij+1,l) ) + bern(ij,l) - bern(ij+1,l) 41 2 CONTINUE41 END DO 42 42 c 43 43 c … … 46 46 c 47 47 CDIR$ IVDEP 48 DO 3ij = iip1+ iip1, ip1jm, iip148 DO ij = iip1+ iip1, ip1jm, iip1 49 49 du( ij,l ) = du( ij - iim,l ) 50 3 CONTINUE50 END DO 51 51 c 52 52 c 53 DO 4ij = 1,ip1jm53 DO ij = 1,ip1jm 54 54 dv( ij,l) = dv(ij,l) + 0.5 * ( teta(ij,l) + teta( ij+iip1,l ) ) * 55 55 * ( pkf(ij+iip1,l) - pkf( ij,l ) ) 56 56 * + bern( ij+iip1,l ) - bern( ij ,l ) 57 4 CONTINUE57 END DO 58 58 c 59 5 CONTINUE59 END DO 60 60 c 61 61 RETURN -
LMDZ6/branches/Amaury_dev/libf/dyn3d/iniinterp_horiz.F
r5082 r5086 74 74 a(i) = rlonuo(i-1) 75 75 b(i) = rlonuo(i) 76 end do76 END DO 77 77 78 78 d(1) = pi/2 … … 80 80 c(j) = rlatvo(j) 81 81 d(j+1) = rlatvo(j) 82 end do82 END DO 83 83 c(jmo+1) = -pi/2 84 84 … … 91 91 an(i) = rlonun(i-1) 92 92 bn(i) = rlonun(i) 93 end do93 END DO 94 94 95 95 dn(1) = pi/2 … … 97 97 cn(j) = rlatvn(j) 98 98 dn(j+1) = rlatvn(j) 99 end do99 END DO 100 100 cn(jmn+1) = -pi/2 101 101 … … 105 105 do jj = 1,jmn+1 106 106 airen(ii,jj) = (bn(ii)-an(ii))*(sin(dn(jj))-sin(cn(jj))) 107 end do108 end do107 END DO 108 END DO 109 109 110 110 c Calcul de la surface des intersections … … 151 151 intersec(ktotal)=(bb-aa)*(sin(dd)-sin(cc)) 152 152 end if 153 end do154 end do153 END DO 154 END DO 155 155 end if 156 end do157 end do156 END DO 157 END DO 158 158 159 159 -
LMDZ6/branches/Amaury_dev/libf/dyn3d/interp_horiz.F
r1907 r5086 73 73 do ii=1, imn+1 74 74 varn(ii,jj,l) =0. 75 end do76 end do77 end do75 END DO 76 END DO 77 END DO 78 78 79 79 c Interpolation horizontale … … 88 88 varn(iik(k),jjk(k),l) = varn(iik(k),jjk(k),l) 89 89 & + varo(ik(k), jk(k),l)*intersec(k)/airen(iik(k),jjk(k)) 90 end do91 end do90 END DO 91 END DO 92 92 93 93 c Une seule valeur au pole pour les variables ! : … … 99 99 totn = totn + varn(ii,1,l) 100 100 tots = tots + varn (ii,jmn+1,l) 101 end do101 END DO 102 102 do ii =1, imn+1 103 103 varn(ii,1,l) = totn/REAL(imn+1) 104 104 varn(ii,jmn+1,l) = tots/REAL(imn+1) 105 end do106 end do105 END DO 106 END DO 107 107 108 108 … … 115 115 !! do ii=1, imn+1 116 116 !! airetest(ii,jj) =0. 117 !! end do118 !! end do117 !! END DO 118 !! END DO 119 119 !! PRINT *, 'ktotal = ', ktotal 120 120 !! PRINT *, 'jmn+1 =', jmn+1, 'imn+1', imn+1 … … 136 136 !! aire_ok = .false. 137 137 !! end if 138 !! end do139 !! end do138 !! END DO 139 !! END DO 140 140 !! ! if (aire_ok) write(*,*) 'INTERP. HORIZ. : AIRES OK' 141 141 !! 99 continue -
LMDZ6/branches/Amaury_dev/libf/dyn3d/tetaleveli1j.F
r5082 r5086 65 65 c Eventuellement, faire l'extrapolation a partir des deux couches 66 66 c les plus basses ou les deux couches les plus hautes: 67 DO 130i = 1, ilon67 DO i = 1, ilon 68 68 cIM IF ( ABS(pres-pgcm(i,ilev) ) .LT. 69 69 IF ( ABS(pres-pgcm(i,ilev) ) > … … 77 77 cIM PRINT*,'i, ABS(pres-pgcm),ABS(pres-pgcm)', 78 78 cIM .i, ABS(pres-pgcm(i,ilev)),ABS(pres-pgcm(i,1)) 79 130 CONTINUE80 DO 150k = 1, ilev-181 DO 140i = 1, ilon79 END DO 80 DO k = 1, ilev-1 81 DO i = 1, ilon 82 82 pbot = pgcm(i,k) 83 83 ptop = pgcm(i,k+1) … … 87 87 lb(i) = k 88 88 ENDIF 89 140 CONTINUE90 150 CONTINUE89 END DO 90 END DO 91 91 c 92 92 c Interpolation lineaire: -
LMDZ6/branches/Amaury_dev/libf/dyn3d/tetaleveli1j1.F
r5082 r5086 65 65 c Eventuellement, faire l'extrapolation a partir des deux couches 66 66 c les plus basses ou les deux couches les plus hautes: 67 DO 130i = 1, ilon67 DO i = 1, ilon 68 68 cIM IF ( ABS(pres-pgcm(i,ilev) ) .LT. 69 69 IF ( ABS(pres-pgcm(i,ilev) ) > … … 77 77 cIM PRINT*,'i, ABS(pres-pgcm),ABS(pres-pgcm)', 78 78 cIM .i, ABS(pres-pgcm(i,ilev)),ABS(pres-pgcm(i,1)) 79 130 CONTINUE80 DO 150k = 1, ilev-181 DO 140i = 1, ilon79 END DO 80 DO k = 1, ilev-1 81 DO i = 1, ilon 82 82 pbot = pgcm(i,k) 83 83 ptop = pgcm(i,k+1) … … 87 87 lb(i) = k 88 88 ENDIF 89 140 CONTINUE90 150 CONTINUE89 END DO 90 END DO 91 91 c 92 92 c Interpolation lineaire: -
LMDZ6/branches/Amaury_dev/libf/dyn3d_common/bernoui.F
r2603 r5086 43 43 c --------------------- 44 44 c 45 DO 4ijl = 1,ngrid*nlay45 DO ijl = 1,ngrid*nlay 46 46 pbern( ijl ) = pphi( ijl ) + pecin( ijl ) 47 4 CONTINUE47 END DO 48 48 c 49 49 c----------------------------------------------------------------------- -
LMDZ6/branches/Amaury_dev/libf/dyn3d_common/convflu.F
r4593 r5086 32 32 INCLUDE "comgeom.h" 33 33 c 34 DO 5l = 1,nbniv34 DO l = 1,nbniv 35 35 c 36 DO 2ij = iip2, ip1jm - 136 DO ij = iip2, ip1jm - 1 37 37 convfl( ij + 1,l ) = xflu( ij,l ) - xflu( ij + 1,l ) + 38 38 * yflu(ij +1,l ) - yflu( ij -iim,l ) 39 2 CONTINUE39 END DO 40 40 c 41 41 c … … 45 45 c 46 46 CDIR$ IVDEP 47 DO 3ij = iip2,ip1jm,iip147 DO ij = iip2,ip1jm,iip1 48 48 convfl( ij,l ) = convfl( ij + iim,l ) 49 3 CONTINUE49 END DO 50 50 c 51 51 c ...... calcul aux poles ....... … … 53 53 convpn = SSUM( iim, yflu( 1 ,l ), 1 ) 54 54 convps = - SSUM( iim, yflu( ip1jm-iim,l ), 1 ) 55 DO 4ij = 1,iip155 DO ij = 1,iip1 56 56 convfl( ij ,l ) = convpn * aire( ij ) / apoln 57 57 convfl( ij+ ip1jm,l ) = convps * aire( ij+ ip1jm) / apols 58 4 CONTINUE58 END DO 59 59 c 60 5 CONTINUE60 END DO 61 61 RETURN 62 62 END -
LMDZ6/branches/Amaury_dev/libf/dyn3d_common/disvert.F90
r4257 r5086 320 320 do l = 1, llm + 1 321 321 read(unit, fmt=*) ap(l), bp(l) 322 end do322 END DO 323 323 close(unit) 324 324 call assert(ap(1) == 0., ap(llm + 1) == 0., bp(1) == 1., & -
LMDZ6/branches/Amaury_dev/libf/dyn3d_common/disvert_noterre.F
r5082 r5086 139 139 do l=1,llm 140 140 read(99,*) zsig(l) 141 end do141 END DO 142 142 CLOSE(99) 143 143 … … 146 146 sig(l) = 0.5 * ( exp(-zsig(l)/scaleheight) + 147 147 & exp(-zsig(l-1)/scaleheight) ) 148 end do148 END DO 149 149 sig(llm+1) =0 150 150 … … 264 264 c zsig(l)= zsig(l-1)-scaleheight* 265 265 c . log((aps(l) + bps(l)*ps)/(aps(l-1) + bps(l-1)*ps)) 266 c end do266 c END DO 267 267 c write(53,'(I3,50F10.5)') iz, zsig 268 c end do268 c END DO 269 269 c close(53) 270 270 c -------------------------------------------------- -
LMDZ6/branches/Amaury_dev/libf/dyn3d_common/diverg.F
r4593 r5086 41 41 c 42 42 c 43 DO 10l = 1,klevel43 DO l = 1,klevel 44 44 c 45 45 DO ij = iip2, ip1jm - 1 … … 70 70 div( ij + ip1jm, l ) = sumyps 71 71 ENDDO 72 10 CONTINUE72 END DO 73 73 c 74 74 -
LMDZ6/branches/Amaury_dev/libf/dyn3d_common/diverg_gam.F
r4593 r5086 44 44 c 45 45 c 46 DO 10l = 1,klevel46 DO l = 1,klevel 47 47 c 48 48 DO ij = iip2, ip1jm - 1 … … 74 74 div( ij + ip1jm, l ) = sumyps 75 75 ENDDO 76 10 CONTINUE76 END DO 77 77 c 78 78 -
LMDZ6/branches/Amaury_dev/libf/dyn3d_common/divergf.F
r4593 r5086 41 41 c 42 42 c 43 DO 10l = 1,klevel43 DO l = 1,klevel 44 44 c 45 45 DO ij = iip2, ip1jm - 1 … … 70 70 div( ij + ip1jm, l ) = sumyps 71 71 ENDDO 72 10 CONTINUE72 END DO 73 73 c 74 74 -
LMDZ6/branches/Amaury_dev/libf/dyn3d_common/divergst.F
r4593 r5086 30 30 c 31 31 c 32 DO 10l = 1,klevel32 DO l = 1,klevel 33 33 c 34 DO 1ij = iip2, ip1jm - 134 DO ij = iip2, ip1jm - 1 35 35 div( ij + 1, l ) = x(ij+1,l) - x(ij,l)+ y(ij-iim,l)-y(ij+1,l) 36 1 CONTINUE36 END DO 37 37 c 38 38 c .... correction pour div( 1,j,l) ...... … … 40 40 c 41 41 CDIR$ IVDEP 42 DO 3ij = iip2,ip1jm,iip142 DO ij = iip2,ip1jm,iip1 43 43 div( ij,l ) = div( ij + iim,l ) 44 3 CONTINUE44 END DO 45 45 c 46 46 c .... calcul aux poles ..... 47 47 c 48 48 c 49 DO 5i = 1,iim49 DO i = 1,iim 50 50 aiy1(i)= y(i,l) 51 51 aiy2(i)= y(i+ip1jmi1,l) 52 5 CONTINUE52 END DO 53 53 sumypn = SSUM ( iim,aiy1,1 ) 54 54 sumyps = SSUM ( iim,aiy2,1 ) 55 DO 7i = 1,iip155 DO i = 1,iip1 56 56 div( i , l ) = - sumypn/iim 57 57 div( i + ip1jm, l ) = sumyps/iim 58 7 CONTINUE58 END DO 59 59 c 60 10 CONTINUE60 END DO 61 61 RETURN 62 62 END -
LMDZ6/branches/Amaury_dev/libf/dyn3d_common/divgrad.F
r2603 r5086 36 36 CALL SCOPY ( ip1jmp1*klevel,h,1,divgra,1 ) 37 37 c 38 DO 10iter = 1,lh38 DO iter = 1,lh 39 39 40 40 CALL filtreg ( divgra,jjp1,klevel,2,1,.true.,1 ) … … 45 45 CALL filtreg ( divgra,jjp1,klevel,2,1,.true.,1) 46 46 47 DO 5l = 1,klevel48 DO 4ij = 1, ip1jmp147 DO l = 1,klevel 48 DO ij = 1, ip1jmp1 49 49 divgra( ij,l ) = - cdivh * divgra( ij,l ) 50 4 CONTINUE51 5 CONTINUE50 END DO 51 END DO 52 52 c 53 10 CONTINUE53 END DO 54 54 RETURN 55 55 END -
LMDZ6/branches/Amaury_dev/libf/dyn3d_common/fxhyp_m.F90
r2598 r5086 191 191 do while (rlonm025(is2) < - pi .and. is2 < iim) 192 192 is2 = is2 + 1 193 end do193 END DO 194 194 195 195 if (rlonm025(is2) < - pi) then … … 202 202 do while (rlonm025(is2) > pi .and. is2 > 1) 203 203 is2 = is2 - 1 204 end do204 END DO 205 205 206 206 if (rlonm025(is2) > pi) then -
LMDZ6/branches/Amaury_dev/libf/dyn3d_common/geopot.F
r2600 r5086 47 47 c calcul de phi au niveau 1 pres du sol ..... 48 48 49 DO 1ij = 1, ngrid49 DO ij = 1, ngrid 50 50 phi( ij,1 ) = phis( ij ) + teta(ij,1) * ( pks(ij) - pk(ij,1) ) 51 1 CONTINUE51 END DO 52 52 53 53 c calcul de phi aux niveaux superieurs ....... -
LMDZ6/branches/Amaury_dev/libf/dyn3d_common/grad.F
r4593 r5086 23 23 c 24 24 c 25 DO 6l = 1,klevel25 DO l = 1,klevel 26 26 c 27 DO 2ij = 1, ip1jmp1 - 127 DO ij = 1, ip1jmp1 - 1 28 28 pgx( ij,l ) = pg( ij +1,l ) - pg( ij,l ) 29 2 CONTINUE29 END DO 30 30 c 31 31 c .... correction pour pgx(ip1,j,l) .... 32 32 c ... pgx(iip1,j,l)= pgx(1,j,l) .... 33 33 CDIR$ IVDEP 34 DO 3ij = iip1, ip1jmp1, iip134 DO ij = iip1, ip1jmp1, iip1 35 35 pgx( ij,l ) = pgx( ij -iim,l ) 36 3 CONTINUE36 END DO 37 37 c 38 DO 4ij = 1,ip1jm38 DO ij = 1,ip1jm 39 39 pgy( ij,l ) = pg( ij,l ) - pg( ij +iip1,l ) 40 4 CONTINUE40 END DO 41 41 c 42 6 CONTINUE42 END DO 43 43 RETURN 44 44 END -
LMDZ6/branches/Amaury_dev/libf/dyn3d_common/gradiv.F
r2603 r5086 37 37 CALL SCOPY( ip1jm*klevel, ycov,1,gdy,1 ) 38 38 c 39 DO 10iter = 1,ld39 DO iter = 1,ld 40 40 c 41 41 CALL diverg( klevel, gdx , gdy, div ) … … 43 43 CALL grad( klevel, div, gdx, gdy ) 44 44 c 45 DO 5l = 1, klevel46 DO 3ij = 1, ip1jmp145 DO l = 1, klevel 46 DO ij = 1, ip1jmp1 47 47 gdx( ij,l ) = - gdx( ij,l ) * cdivu 48 3 CONTINUE49 DO 4ij = 1, ip1jm48 END DO 49 DO ij = 1, ip1jm 50 50 gdy( ij,l ) = - gdy( ij,l ) * cdivu 51 4 CONTINUE52 5 CONTINUE51 END DO 52 END DO 53 53 c 54 10 CONTINUE54 END DO 55 55 RETURN 56 56 END -
LMDZ6/branches/Amaury_dev/libf/dyn3d_common/inigeom.F
r5082 r5086 224 224 c 225 225 xo1 = 0. 226 DO 10iter = 1, itmax226 DO iter = 1, itmax 227 227 x1 = xo1 228 228 f = x1+ alphax *SIN(x1-pxo) … … 232 232 IF( xdm<=eps )GO TO 11 233 233 xo1 = x1 234 10 CONTINUE234 END DO 235 235 11 CONTINUE 236 236 c … … 241 241 C 242 242 yo1 = 0. 243 DO 15iter = 1,itmay243 DO iter = 1,itmay 244 244 y1 = yo1 245 245 f = y1 + alphay* SIN(y1-pyo) … … 249 249 IF(ydm<=eps) GO TO 17 250 250 yo1 = y1 251 15 CONTINUE251 END DO 252 252 c 253 253 17 CONTINUE … … 346 346 c 347 347 c 348 DO 35j = 1, jjp1348 DO j = 1, jjp1 349 349 c 350 350 IF ( j. eq. 1 ) THEN … … 356 356 radclatm = 0.5* rad * coslatm 357 357 c 358 DO 30i = 1, iim358 DO i = 1, iim 359 359 xprp = xprimp025( i ) 360 360 xprm = xprimm025( i ) … … 365 365 cvij2 ( i,1 ) = 0.5* rad * yprm 366 366 cvij3 ( i,1 ) = cvij2(i,1) 367 30 CONTINUE367 END DO 368 368 c 369 369 DO i = 1, iim … … 387 387 radclatp = 0.5* rad * coslatp 388 388 c 389 DO 31i = 1,iim389 DO i = 1,iim 390 390 xprp = xprimp025( i ) 391 391 xprm = xprimm025( i ) … … 396 396 cvij1(i,jjp1) = 0.5 * rad* yprp 397 397 cvij4(i,jjp1) = cvij1(i,jjp1) 398 31 CONTINUE398 END DO 399 399 c 400 400 DO i = 1, iim … … 428 428 ai14 = un4rad2 * coslatp * yprp 429 429 ai23 = un4rad2 * coslatm * yprm 430 DO 32i = 1,iim430 DO i = 1,iim 431 431 xprp = xprimp025( i ) 432 432 xprm = xprimm025( i ) … … 444 444 cvij3 ( i,j ) = cvij2(i,j) 445 445 cvij4 ( i,j ) = cvij1(i,j) 446 32 CONTINUE446 END DO 447 447 c 448 448 END IF … … 463 463 aireij4 (iip1,j) = aireij4 (1,j ) 464 464 465 35 CONTINUE465 END DO 466 466 c 467 467 c .............................................................. 468 468 c 469 DO 37j = 1, jjp1470 DO 36i = 1, iim469 DO j = 1, jjp1 470 DO i = 1, iim 471 471 aire ( i,j ) = aireij1(i,j) + aireij2(i,j) + aireij3(i,j) + 472 472 * aireij4(i,j) … … 479 479 alpha2p3( i,j ) = alpha2 (i,j) + alpha3 (i,j) 480 480 alpha3p4( i,j ) = alpha3 (i,j) + alpha4 (i,j) 481 36 CONTINUE481 END DO 482 482 c 483 483 c … … 491 491 alpha2p3(iip1,j) = alpha2p3(1,j) 492 492 alpha3p4(iip1,j) = alpha3p4(1,j) 493 37 CONTINUE494 c 495 496 DO 42j = 1,jjp1497 DO 41i = 1,iim493 END DO 494 c 495 496 DO j = 1,jjp1 497 DO i = 1,iim 498 498 aireu (i,j)= aireij1(i,j) + aireij2(i,j) + aireij4(i+1,j) + 499 499 * aireij3(i+1,j) … … 502 502 unsair_gam2( i,j)= unsaire(i,j)** ( - gamdi_h ) 503 503 airesurg ( i,j)= aire(i,j)/ g 504 41 CONTINUE504 END DO 505 505 aireu (iip1,j) = aireu (1,j) 506 506 unsaire (iip1,j) = unsaire(1,j) … … 508 508 unsair_gam2(iip1,j) = unsair_gam2(1,j) 509 509 airesurg (iip1,j) = airesurg(1,j) 510 42 CONTINUE511 c 512 c 513 DO 48j = 1,jjm510 END DO 511 c 512 c 513 DO j = 1,jjm 514 514 c 515 515 DO i=1,iim … … 529 529 unsairz_gam(iip1,j) = unsairz_gam(1,j) 530 530 c 531 48 CONTINUE531 END DO 532 532 c 533 533 c -
LMDZ6/branches/Amaury_dev/libf/dyn3d_common/inter_barxy_m.F90
r5082 r5086 270 270 x0 = xxid(idat) 271 271 idat = idat + 1 272 end do272 END DO 273 273 IF (xxim(imod)<xxid(idat)) THEN 274 274 dx = xxim(imod) - x0 … … 287 287 idat = idat + 1 288 288 END IF 289 end do289 END DO 290 290 291 291 END function inter_barx … … 339 339 y0 = yjdat(jdat) 340 340 jdat = jdat + 1 341 end do341 END DO 342 342 IF (yjmod(jmod) < yjdat(jdat)) THEN 343 343 dy = yjmod(jmod) - y0 … … 357 357 jdat = jdat + 1 358 358 END IF 359 end do359 END DO 360 360 ! Le test de fin suppose que l'interface 0 est commune aux deux 361 361 ! grilles "yjdat" et "yjmod". -
LMDZ6/branches/Amaury_dev/libf/dyn3d_common/interpre.F
r2622 r5086 41 41 42 42 c CALCUL DE LA PRESSION DE SURFACE 43 c Les coefficients ap et bp sont pass és en common44 c Calcul de la pression au sol en mb optimis ée pour43 c Les coefficients ap et bp sont pass�s en common 44 c Calcul de la pression au sol en mb optimis�e pour 45 45 c la vectorialisation 46 46 … … 62 62 do i=1,iim 63 63 psppm(i,j)=smass(i,j)/aire(i,j)*g*0.01 64 end do65 end do64 END DO 65 END DO 66 66 67 67 c RECONSTRUCTION DES CHAMPS CONTRAVARIANTS 68 68 c Le programme ppm3d travaille avec les composantes 69 c de vitesse et pas les flux, on doit donc passer de l'un àl'autre70 c Dans le m ême temps, on fait le changement d'orientation du vent en v69 c de vitesse et pas les flux, on doit donc passer de l'un � l'autre 70 c Dans le m�me temps, on fait le changement d'orientation du vent en v 71 71 do l=1,llm 72 72 do j=1,jjm … … 99 99 100 100 c INVERSION DES NIVEAUX 101 c le programme ppm3d travaille avec une 3 ème coordonnée inversée par rapport101 c le programme ppm3d travaille avec une 3�me coordonn�e invers�e par rapport 102 102 c de celle du LMDZ: z=1<=>niveau max, z=llm+1<=>surface 103 c On passe donc des niveaux du LMDZ àceux de Lin103 c On passe donc des niveaux du LMDZ � ceux de Lin 104 104 105 105 do l=1,llm+1 -
LMDZ6/branches/Amaury_dev/libf/dyn3d_common/invert_zoom_x_m.F90
r2598 r5086 39 39 do while (xfi < xf(it) .and. it >= 1) 40 40 it = it - 1 41 end do41 END DO 42 42 43 43 ! Calcul de Xf(xvrai(i)) -
LMDZ6/branches/Amaury_dev/libf/dyn3d_common/massdair.F
r2597 r5086 82 82 c======================================================================= 83 83 84 DO 100l = 1 , llm84 DO l = 1 , llm 85 85 c 86 86 DO ij = 1, ip1jmp1 … … 103 103 c ENDDO 104 104 105 100 CONTINUE 105 END DO 106 106 c 107 107 RETURN -
LMDZ6/branches/Amaury_dev/libf/dyn3d_common/nxgrad.F
r4593 r5086 22 22 c 23 23 c 24 DO 10l = 1,klevel24 DO l = 1,klevel 25 25 c 26 DO 1ij = 2, ip1jm26 DO ij = 2, ip1jm 27 27 y( ij,l ) = ( rot( ij,l ) - rot( ij-1,l ) ) * cvsurcuv( ij ) 28 1 CONTINUE28 END DO 29 29 c 30 30 c ..... correction pour y ( 1,j,l ) ...... … … 32 32 c .... y(1,j,l)= y(iip1,j,l) .... 33 33 CDIR$ IVDEP 34 DO 2ij = 1, ip1jm, iip134 DO ij = 1, ip1jm, iip1 35 35 y( ij,l ) = y( ij +iim,l ) 36 2 CONTINUE36 END DO 37 37 c 38 DO 4ij = iip2,ip1jm38 DO ij = iip2,ip1jm 39 39 x( ij,l ) = ( rot( ij,l ) - rot( ij -iip1,l ) ) * cusurcvu( ij ) 40 4 CONTINUE41 DO 6ij = 1,iip140 END DO 41 DO ij = 1,iip1 42 42 x( ij ,l ) = 0. 43 43 x( ij +ip1jm,l ) = 0. 44 6 CONTINUE44 END DO 45 45 c 46 10 CONTINUE46 END DO 47 47 RETURN 48 48 END -
LMDZ6/branches/Amaury_dev/libf/dyn3d_common/nxgrad_gam.F
r4593 r5086 21 21 INTEGER l,ij 22 22 c 23 DO 10l = 1,klevel23 DO l = 1,klevel 24 24 c 25 DO 1ij = 2, ip1jm25 DO ij = 2, ip1jm 26 26 y( ij,l ) = (rot( ij,l ) - rot( ij-1,l )) * cvscuvgam( ij ) 27 1 CONTINUE27 END DO 28 28 c 29 29 c ..... correction pour y ( 1,j,l ) ...... … … 31 31 c .... y(1,j,l)= y(iip1,j,l) .... 32 32 CDIR$ IVDEP 33 DO 2ij = 1, ip1jm, iip133 DO ij = 1, ip1jm, iip1 34 34 y( ij,l ) = y( ij +iim,l ) 35 2 CONTINUE35 END DO 36 36 c 37 DO 4ij = iip2,ip1jm37 DO ij = iip2,ip1jm 38 38 x( ij,l ) = (rot( ij,l ) - rot( ij -iip1,l )) * cuscvugam( ij ) 39 4 CONTINUE40 DO 6ij = 1,iip139 END DO 40 DO ij = 1,iip1 41 41 x( ij ,l ) = 0. 42 42 x( ij +ip1jm,l ) = 0. 43 6 CONTINUE43 END DO 44 44 c 45 10 CONTINUE45 END DO 46 46 RETURN 47 47 END -
LMDZ6/branches/Amaury_dev/libf/dyn3d_common/nxgradst.F
r4593 r5086 21 21 INTEGER l,ij 22 22 c 23 DO 10l = 1,klevel23 DO l = 1,klevel 24 24 c 25 DO 1ij = 2, ip1jm25 DO ij = 2, ip1jm 26 26 y(ij,l)=( rot(ij,l) - rot(ij-1,l)) 27 1 CONTINUE27 END DO 28 28 c 29 29 c ..... correction pour y ( 1,j,l ) ...... … … 31 31 c .... y(1,j,l)= y(iip1,j,l) .... 32 32 33 DO 2ij = 1, ip1jm, iip133 DO ij = 1, ip1jm, iip1 34 34 y( ij,l ) = y( ij +iim,l ) 35 2 CONTINUE35 END DO 36 36 c 37 DO 4ij = iip2,ip1jm37 DO ij = iip2,ip1jm 38 38 x(ij,l)= rot(ij,l)-rot(ij-iip1,l) 39 4 CONTINUE40 DO 6ij = 1,iip139 END DO 40 DO ij = 1,iip1 41 41 x( ij ,l ) = 0. 42 42 x( ij +ip1jm,l ) = 0. 43 6 CONTINUE43 END DO 44 44 c 45 10 CONTINUE45 END DO 46 46 RETURN 47 47 END -
LMDZ6/branches/Amaury_dev/libf/dyn3d_common/nxgrarot.F
r2603 r5086 36 36 CALL SCOPY ( ip1jm*klevel, ycov, 1, gry, 1 ) 37 37 c 38 DO 10iter = 1,lr38 DO iter = 1,lr 39 39 CALL rotat (klevel,grx, gry, rot ) 40 40 CALL filtreg( rot, jjm, klevel, 2,1, .false.,2) 41 41 CALL nxgrad (klevel,rot, grx, gry ) 42 42 c 43 DO 5l = 1, klevel44 DO 2ij = 1, ip1jm43 DO l = 1, klevel 44 DO ij = 1, ip1jm 45 45 gry( ij,l ) = - gry( ij,l ) * crot 46 2 CONTINUE47 DO 3ij = 1, ip1jmp146 END DO 47 DO ij = 1, ip1jmp1 48 48 grx( ij,l ) = - grx( ij,l ) * crot 49 3 CONTINUE50 5 CONTINUE49 END DO 50 END DO 51 51 c 52 10 CONTINUE52 END DO 53 53 RETURN 54 54 END -
LMDZ6/branches/Amaury_dev/libf/dyn3d_common/pbar.F
r4593 r5086 87 87 88 88 89 DO 1ij = 1, ip1jmp1 - 189 DO ij = 1, ip1jmp1 - 1 90 90 pbarx( ij ) = pext(ij) * alpha1p2(ij) + pext(ij+1)*alpha3p4(ij+1) 91 1 CONTINUE91 END DO 92 92 93 93 c .... correction pour pbarx( iip1,j) ..... … … 95 95 c ... pbarx(iip1,j)= pbarx(1,j) ... 96 96 CDIR$ IVDEP 97 DO 2ij = iip1, ip1jmp1, iip197 DO ij = iip1, ip1jmp1, iip1 98 98 pbarx( ij ) = pbarx( ij - iim ) 99 2 CONTINUE99 END DO 100 100 101 101 102 DO 3ij = 1,ip1jm102 DO ij = 1,ip1jm 103 103 pbary( ij ) = pext( ij ) * alpha2p3( ij ) + 104 104 * pext( ij+iip1 ) * alpha1p4( ij+iip1 ) 105 3 CONTINUE105 END DO 106 106 107 107 108 DO 5ij = 1, ip1jm - 1108 DO ij = 1, ip1jm - 1 109 109 pbarxy( ij ) = pext(ij)*alpha2(ij) + pext(ij+1)*alpha3(ij+1) + 110 110 * pext(ij+iip1)*alpha1(ij+iip1) + pext(ij+iip2)*alpha4(ij+iip2) 111 5 CONTINUE111 END DO 112 112 113 113 … … 116 116 CDIR$ IVDEP 117 117 118 DO 7ij = iip1, ip1jm, iip1118 DO ij = iip1, ip1jm, iip1 119 119 pbarxy( ij ) = pbarxy( ij - iim ) 120 7 CONTINUE120 END DO 121 121 122 122 -
LMDZ6/branches/Amaury_dev/libf/dyn3d_common/prather.F
r5082 r5086 149 149 call advxp( limit,0.5*dt,pbaru,sm,s0,sx,sy,sz 150 150 . ,sxx,sxy,sxz,syy,syz,szz,1 ) 151 end do151 END DO 152 152 do l=1,llm 153 153 do i=1,iip1 … … 206 206 call advxp( limit,0.5*dt,pbaru,sm,s0,sx,sy,sz 207 207 . ,sxx,sxy,sxz,syy,syz,szz,1 ) 208 end do208 END DO 209 209 c--------------------------------------------------------- 210 210 c--------------------------------------------------------- -
LMDZ6/branches/Amaury_dev/libf/dyn3d_common/psextbar.F
r4593 r5086 89 89 90 90 91 DO 5ij = 1, ip1jm - 191 DO ij = 1, ip1jm - 1 92 92 psexbarxy( ij ) = pext(ij)*alpha2(ij) + pext(ij+1)*alpha3(ij+1) + 93 93 * pext(ij+iip1)*alpha1(ij+iip1) + pext(ij+iip2)*alpha4(ij+iip2) 94 5 CONTINUE94 END DO 95 95 96 96 … … 99 99 CDIR$ IVDEP 100 100 101 DO 7ij = iip1, ip1jm, iip1101 DO ij = iip1, ip1jm, iip1 102 102 psexbarxy( ij ) = psexbarxy( ij - iim ) 103 7 CONTINUE103 END DO 104 104 105 105 -
LMDZ6/branches/Amaury_dev/libf/dyn3d_common/rotat.F
r4593 r5086 30 30 c 31 31 c 32 DO 10l = 1,klevel32 DO l = 1,klevel 33 33 c 34 34 DO ij = 1, ip1jm - 1 … … 44 44 ENDDO 45 45 c 46 10 CONTINUE46 END DO 47 47 48 48 ccc CALL filtreg( rot, jjm, klevel, 2, 2, .FALSE., 1 ) -
LMDZ6/branches/Amaury_dev/libf/dyn3d_common/rotat_nfil.F
r4593 r5086 30 30 c 31 31 c 32 DO 10l = 1,klevel32 DO l = 1,klevel 33 33 c 34 34 DO ij = 1, ip1jm - 1 … … 44 44 ENDDO 45 45 c 46 10 CONTINUE46 END DO 47 47 48 48 RETURN -
LMDZ6/branches/Amaury_dev/libf/dyn3d_common/rotatf.F
r4593 r5086 31 31 c 32 32 c 33 DO 10l = 1,klevel33 DO l = 1,klevel 34 34 c 35 35 DO ij = 1, ip1jm - 1 … … 45 45 ENDDO 46 46 c 47 10 CONTINUE47 END DO 48 48 49 49 CALL filtreg( rot, jjm, klevel, 2, 2, .FALSE., 1 ) -
LMDZ6/branches/Amaury_dev/libf/dyn3d_common/rotatst.F
r4593 r5086 24 24 c 25 25 c 26 DO 5l = 1,klevel26 DO l = 1,klevel 27 27 c 28 DO 1ij = 1, ip1jm - 128 DO ij = 1, ip1jm - 1 29 29 rot( ij,l ) = ( y( ij+1 , l ) - y( ij,l ) + 30 30 * x(ij +iip1, l ) - x( ij,l ) ) 31 1 CONTINUE31 END DO 32 32 c 33 33 c .... correction pour rot( iip1,j,l) .... … … 35 35 c .... rot(iip1,j,l)= rot(1,j,l) ... 36 36 CDIR$ IVDEP 37 DO 2ij = iip1, ip1jm, iip137 DO ij = iip1, ip1jm, iip1 38 38 rot( ij,l ) = rot( ij -iim,l ) 39 2 CONTINUE39 END DO 40 40 c 41 5 CONTINUE41 END DO 42 42 RETURN 43 43 END -
LMDZ6/branches/Amaury_dev/libf/dyn3dmem/advect_new_loc.F
r2622 r5086 63 63 deuxjour = 2. * daysec 64 64 65 DO 1ij = 1, ip1jmp165 DO ij = 1, ip1jmp1 66 66 unsaire2(ij) = unsaire(ij) * unsaire(ij) 67 1 CONTINUE67 END DO 68 68 END IF 69 69 … … 175 175 176 176 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 177 DO 20l = 1, llmm1177 DO l = 1, llmm1 178 178 179 179 … … 183 183 if (pole_sud) ije=ij_end 184 184 185 DO 5ij = ijb, ije185 DO ij = ijb, ije 186 186 wsur2( ij ) = - 0.5 * w( ij,l+1 ) 187 5 CONTINUE187 END DO 188 188 189 189 … … 195 195 if (pole_sud) ije=ije-iip1 196 196 197 DO 6ij = ijb ,ije-1197 DO ij = ijb ,ije-1 198 198 ww = wsur2 ( ij ) + wsur2( ij+1 ) 199 199 uu = 0.5 * ( ucov(ij,l) + ucov(ij,l+1) ) 200 200 du1(ij,l) = ww * ( uu - uav(ij, l ) )/massebx(ij, l ) 201 201 du2(ij,l+1)= ww * ( uu - uav(ij,l+1) )/massebx(ij,l+1) 202 6 CONTINUE202 END DO 203 203 204 204 c ................. calcul pour dv ..................... … … 207 207 if (pole_sud) ije=ij_end-iip1 208 208 209 DO 8ij = ijb, ije209 DO ij = ijb, ije 210 210 ww = wsur2( ij+iip1 ) + wsur2( ij ) 211 211 vv = 0.5 * ( vcov(ij,l) + vcov(ij,l+1) ) 212 212 dv1(ij,l) = ww * (vv - vav(ij, l ) )/masseby(ij, l ) 213 213 dv2(ij,l+1)= ww * (vv - vav(ij,l+1) )/masseby(ij,l+1) 214 8 CONTINUE214 END DO 215 215 216 216 c … … 226 226 ije=ij_end 227 227 228 DO 15ij = ijb, ije228 DO ij = ijb, ije 229 229 ww = wsur2(ij) * (teta(ij,l) + teta(ij,l+1) ) 230 230 dteta1(ij, l ) = ww 231 231 dteta2(ij,l+1) = ww 232 15 CONTINUE232 END DO 233 233 234 234 c ym ---> conser a voir plus tard … … 243 243 c END IF 244 244 245 20 CONTINUE245 END DO 246 246 c$OMP END DO 247 247 -
LMDZ6/branches/Amaury_dev/libf/dyn3dmem/bernoui_loc.F
r2603 r5086 54 54 DO l=1,llm 55 55 56 DO 4ij = ijb,ije56 DO ij = ijb,ije 57 57 pbern( ij,l ) = pphi( ij,l ) + pecin( ij,l ) 58 4 CONTINUE58 END DO 59 59 60 60 ENDDO -
LMDZ6/branches/Amaury_dev/libf/dyn3dmem/convflu_loc.F
r4593 r5086 34 34 35 35 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 36 DO 5l = 1,nbniv36 DO l = 1,nbniv 37 37 c 38 38 ijb=ij_begin … … 42 42 IF (pole_sud) ije=ij_end-iip1 43 43 44 DO 2ij = ijb , ije - 144 DO ij = ijb , ije - 1 45 45 convfl(ij+1,l) = xflu(ij,l) - xflu(ij+ 1,l) + 46 46 * yflu(ij +1,l ) - yflu( ij -iim,l ) 47 2 CONTINUE47 END DO 48 48 c 49 49 c … … 53 53 c 54 54 CDIR$ IVDEP 55 DO 3ij = ijb,ije,iip155 DO ij = ijb,ije,iip1 56 56 convfl( ij,l ) = convfl( ij + iim,l ) 57 3 CONTINUE57 END DO 58 58 c 59 59 c ...... calcul aux poles ....... … … 79 79 ENDIF 80 80 81 5 CONTINUE81 END DO 82 82 c$OMP END DO NOWAIT 83 83 RETURN -
LMDZ6/branches/Amaury_dev/libf/dyn3dmem/covcont_loc.F
r4593 r5086 44 44 45 45 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 46 DO 10l = 1,klevel46 DO l = 1,klevel 47 47 48 DO 2ij = ijb_u,ije_u48 DO ij = ijb_u,ije_u 49 49 ucont( ij,l ) = ucov( ij,l ) * unscu2( ij ) 50 2 CONTINUE50 END DO 51 51 52 DO 4ij = ijb_v,ije_v52 DO ij = ijb_v,ije_v 53 53 vcont( ij,l ) = vcov( ij,l ) * unscv2( ij ) 54 4 CONTINUE54 END DO 55 55 56 10 CONTINUE56 END DO 57 57 c$OMP END DO NOWAIT 58 58 RETURN -
LMDZ6/branches/Amaury_dev/libf/dyn3dmem/diverg_gam_loc.F
r4593 r5086 51 51 52 52 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 53 DO 10l = 1,klevel53 DO l = 1,klevel 54 54 c 55 55 DO ij = ijb, ije - 1 … … 91 91 ENDDO 92 92 endif 93 10 CONTINUE93 END DO 94 94 c$OMP END DO NOWAIT 95 95 c -
LMDZ6/branches/Amaury_dev/libf/dyn3dmem/diverg_p.F
r4593 r5086 47 47 48 48 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 49 DO 10l = 1,klevel49 DO l = 1,klevel 50 50 c 51 51 DO ij = ijb, ije - 1 … … 88 88 89 89 90 10 CONTINUE90 END DO 91 91 c$OMP END DO NOWAIT 92 92 c -
LMDZ6/branches/Amaury_dev/libf/dyn3dmem/divergf_loc.F
r4593 r5086 49 49 50 50 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 51 DO 10l = 1,klevel51 DO l = 1,klevel 52 52 c 53 53 DO ij = ijb, ije - 1 … … 95 95 endif 96 96 97 10 CONTINUE97 END DO 98 98 c$OMP END DO NOWAIT 99 99 -
LMDZ6/branches/Amaury_dev/libf/dyn3dmem/dteta1_loc.F
r2603 r5086 39 39 40 40 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 41 DO 5l = 1,llm41 DO l = 1,llm 42 42 43 43 ijb=ij_begin … … 47 47 if (pole_sud) ije=ij_end-iip1 48 48 49 DO 1ij = ijb, ije - 149 DO ij = ijb, ije - 1 50 50 hbxu(ij,l) = pbaru(ij,l) * 0.5 * ( teta(ij,l)+teta(ij+1,l) ) 51 1 CONTINUE51 END DO 52 52 53 53 c .... correction pour hbxu(iip1,j,l) ..... … … 55 55 56 56 CDIR$ IVDEP 57 DO 2ij = ijb+iip1-1, ije, iip157 DO ij = ijb+iip1-1, ije, iip1 58 58 hbxu( ij, l ) = hbxu( ij - iim, l ) 59 2 CONTINUE59 END DO 60 60 61 61 ijb=ij_begin-iip1 62 62 if (pole_nord) ijb=ij_begin 63 63 64 DO 3ij = ijb,ije64 DO ij = ijb,ije 65 65 hbyv(ij,l)= pbarv(ij, l)* 0.5 * ( teta(ij, l)+teta(ij+iip1,l) ) 66 3 CONTINUE66 END DO 67 67 68 68 if (.not. pole_sud) then … … 71 71 endif 72 72 73 5 CONTINUE73 END DO 74 74 c$OMP END DO NOWAIT 75 75 -
LMDZ6/branches/Amaury_dev/libf/dyn3dmem/dudv1_loc.F
r4593 r5086 28 28 29 29 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 30 DO 10l = 1,llm30 DO l = 1,llm 31 31 c 32 32 ijb=ij_begin … … 36 36 if (pole_sud) ije=ij_end-iip1 37 37 38 DO 2 ij = ijb, ije-138 DO ij = ijb, ije-1 39 39 du( ij,l ) = 0.125 *( vorpot(ij-iip1, l) + vorpot( ij, l) ) * 40 40 * ( pbarv(ij-iip1, l) + pbarv(ij-iim, l) + 41 41 * pbarv( ij , l) + pbarv(ij+ 1 , l) ) 42 2 CONTINUE42 END DO 43 43 44 44 … … 46 46 if (pole_nord) ijb=ij_begin 47 47 48 DO 3 ij = ijb, ije-148 DO ij = ijb, ije-1 49 49 dv( ij+1,l ) = - 0.125 *( vorpot(ij, l) + vorpot(ij+1, l) ) * 50 50 * ( pbaru(ij, l) + pbaru(ij+1 , l) + 51 51 * pbaru(ij+iip1, l) + pbaru(ij+iip2, l) ) 52 3 CONTINUE52 END DO 53 53 c 54 54 c .... correction pour dv( 1,j,l ) ..... … … 56 56 c 57 57 CDIR$ IVDEP 58 DO 4ij = ijb, ije, iip158 DO ij = ijb, ije, iip1 59 59 dv( ij,l ) = dv( ij + iim, l ) 60 4 CONTINUE60 END DO 61 61 c 62 10 CONTINUE62 END DO 63 63 c$OMP END DO NOWAIT 64 64 RETURN -
LMDZ6/branches/Amaury_dev/libf/dyn3dmem/dudv2_loc.F
r2600 r5086 33 33 c 34 34 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 35 DO 5l = 1,llm35 DO l = 1,llm 36 36 c 37 37 ijb=ij_begin … … 40 40 if (pole_sud) ije=ije-iip1 41 41 42 DO 2ij = ijb, ije - 142 DO ij = ijb, ije - 1 43 43 du(ij,l) = du(ij,l) + 0.5* ( teta( ij,l ) + teta( ij+1,l ) ) * 44 44 * ( pkf( ij,l ) - pkf(ij+1,l) ) + bern(ij,l) - bern(ij+1,l) 45 2 CONTINUE45 END DO 46 46 c 47 47 c … … 50 50 c 51 51 CDIR$ IVDEP 52 DO 3ij = ijb+iip1-1, ije, iip152 DO ij = ijb+iip1-1, ije, iip1 53 53 du( ij,l ) = du( ij - iim,l ) 54 3 CONTINUE54 END DO 55 55 c 56 56 c 57 57 if (pole_nord) ijb=ijb-iip1 58 58 59 DO 4ij = ijb,ije59 DO ij = ijb,ije 60 60 dv( ij,l) = dv(ij,l) + 0.5 * ( teta(ij,l) + teta( ij+iip1,l ) ) * 61 61 * ( pkf(ij+iip1,l) - pkf( ij,l ) ) 62 62 * + bern( ij+iip1,l ) - bern( ij ,l ) 63 4 CONTINUE63 END DO 64 64 c 65 5 CONTINUE65 END DO 66 66 c$OMP END DO NOWAIT 67 67 c -
LMDZ6/branches/Amaury_dev/libf/dyn3dmem/grad_loc.F
r4593 r5086 23 23 c 24 24 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 25 DO 6l = 1,klevel25 DO l = 1,klevel 26 26 c 27 27 ijb=ij_begin 28 28 ije=ij_end 29 DO 2ij = ijb, ije - 129 DO ij = ijb, ije - 1 30 30 pgx( ij,l ) = pg( ij +1,l ) - pg( ij,l ) 31 2 CONTINUE31 END DO 32 32 c 33 33 c .... correction pour pgx(ip1,j,l) .... 34 34 c ... pgx(iip1,j,l)= pgx(1,j,l) .... 35 35 CDIR$ IVDEP 36 DO 3ij = ijb+iip1-1, ije, iip136 DO ij = ijb+iip1-1, ije, iip1 37 37 pgx( ij,l ) = pgx( ij -iim,l ) 38 3 CONTINUE38 END DO 39 39 c 40 40 ijb=ij_begin-iip1 … … 43 43 if (pole_sud) ije=ij_end-iip1 44 44 45 DO 4ij = ijb,ije45 DO ij = ijb,ije 46 46 pgy( ij,l ) = pg( ij,l ) - pg( ij +iip1,l ) 47 4 CONTINUE47 END DO 48 48 c 49 6 CONTINUE49 END DO 50 50 c$OMP END DO NOWAIT 51 51 -
LMDZ6/branches/Amaury_dev/libf/dyn3dmem/grad_p.F
r4593 r5086 23 23 c 24 24 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 25 DO 6l = 1,klevel25 DO l = 1,klevel 26 26 c 27 27 ijb=ij_begin 28 28 ije=ij_end 29 DO 2ij = ijb, ije - 129 DO ij = ijb, ije - 1 30 30 pgx( ij,l ) = pg( ij +1,l ) - pg( ij,l ) 31 2 CONTINUE31 END DO 32 32 c 33 33 c .... correction pour pgx(ip1,j,l) .... 34 34 c ... pgx(iip1,j,l)= pgx(1,j,l) .... 35 35 CDIR$ IVDEP 36 DO 3ij = ijb+iip1-1, ije, iip136 DO ij = ijb+iip1-1, ije, iip1 37 37 pgx( ij,l ) = pgx( ij -iim,l ) 38 3 CONTINUE38 END DO 39 39 c 40 40 ijb=ij_begin-iip1 … … 43 43 if (pole_sud) ije=ij_end-iip1 44 44 45 DO 4ij = ijb,ije45 DO ij = ijb,ije 46 46 pgy( ij,l ) = pg( ij,l ) - pg( ij +iip1,l ) 47 4 CONTINUE47 END DO 48 48 c 49 6 CONTINUE49 END DO 50 50 c$OMP END DO NOWAIT 51 51 -
LMDZ6/branches/Amaury_dev/libf/dyn3dmem/integrd_loc.F
r5082 r5086 124 124 125 125 c$OMP DO SCHEDULE(STATIC) 126 DO 2ij = ijb,ije126 DO ij = ijb,ije 127 127 pscr (ij) = ps0(ij) 128 128 ps (ij) = psm1(ij) + dt * dp(ij) 129 129 130 2 CONTINUE130 END DO 131 131 132 132 c$OMP END DO … … 250 250 251 251 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 252 DO 10l = 1,llm252 DO l = 1,llm 253 253 254 254 ijb=ij_begin … … 257 257 if (pole_sud) ije=ij_end-iip1 258 258 259 DO 4ij = ijb,ije259 DO ij = ijb,ije 260 260 uscr( ij ) = ucov( ij,l ) 261 261 ucov( ij,l ) = ucovm1( ij,l ) + dt * du( ij,l ) 262 4 CONTINUE262 END DO 263 263 264 264 ijb=ij_begin … … 266 266 if (pole_sud) ije=ij_end-iip1 267 267 268 DO 5ij = ijb,ije268 DO ij = ijb,ije 269 269 vscr( ij ) = vcov( ij,l ) 270 270 vcov( ij,l ) = vcovm1( ij,l ) + dt * dv( ij,l ) 271 5 CONTINUE271 END DO 272 272 273 273 ijb=ij_begin 274 274 ije=ij_end 275 275 276 DO 6ij = ijb,ije276 DO ij = ijb,ije 277 277 hscr( ij ) = teta(ij,l) 278 278 teta ( ij,l ) = tetam1(ij,l) * massem1(ij,l) / masse(ij,l) 279 279 $ + dt * dteta(ij,l) / masse(ij,l) 280 6 CONTINUE280 END DO 281 281 282 282 c .... Calcul de la valeur moyenne, unique aux poles pour teta ...... … … 324 324 END IF 325 325 326 10 CONTINUE326 END DO 327 327 c$OMP END DO NOWAIT 328 328 -
LMDZ6/branches/Amaury_dev/libf/dyn3dmem/massdair_loc.F
r2597 r5086 92 92 93 93 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 94 DO 100l = 1 , llm94 DO l = 1 , llm 95 95 c 96 96 DO ij = ijb, ije … … 113 113 c ENDDO 114 114 115 100 CONTINUE 115 END DO 116 116 c$OMP END DO NOWAIT 117 117 c -
LMDZ6/branches/Amaury_dev/libf/dyn3dmem/mod_hallo.F90
r5082 r5086 169 169 do while (Buffer_Pos(Index_Pos)==-1 .and. Index_Pos>1) 170 170 Index_Pos=Index_Pos-1 171 end do171 END DO 172 172 173 173 end subroutine deallocate_buffer -
LMDZ6/branches/Amaury_dev/libf/dyn3dmem/nxgrad_gam_loc.F
r4593 r5086 25 25 c 26 26 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 27 DO 10l = 1,klevel27 DO l = 1,klevel 28 28 c 29 29 ijb=ij_begin … … 31 31 if(pole_sud) ije=ij_end-iip1 32 32 33 DO 1ij = ijb+1, ije33 DO ij = ijb+1, ije 34 34 y( ij,l ) = (rot( ij,l ) - rot( ij-1,l )) * cvscuvgam( ij ) 35 1 CONTINUE35 END DO 36 36 c 37 37 c ..... correction pour y ( 1,j,l ) ...... … … 39 39 c .... y(1,j,l)= y(iip1,j,l) .... 40 40 CDIR$ IVDEP 41 DO 2ij = ijb, ije, iip141 DO ij = ijb, ije, iip1 42 42 y( ij,l ) = y( ij +iim,l ) 43 2 CONTINUE43 END DO 44 44 c 45 45 ijb=ij_begin … … 48 48 if(pole_sud) ije=ij_end-iip1 49 49 50 DO 4ij = ijb,ije50 DO ij = ijb,ije 51 51 x( ij,l ) = (rot( ij,l ) - rot( ij -iip1,l )) * cuscvugam( ij ) 52 4 CONTINUE52 END DO 53 53 54 54 if (pole_nord) then … … 64 64 endif 65 65 c 66 10 CONTINUE66 END DO 67 67 c$OMP END DO NOWAIT 68 68 RETURN -
LMDZ6/branches/Amaury_dev/libf/dyn3dmem/nxgrad_loc.F
r4593 r5086 23 23 c 24 24 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 25 DO 10l = 1,klevel25 DO l = 1,klevel 26 26 c 27 27 ijb=ij_begin … … 29 29 if (pole_sud) ije=ij_end-iip1 30 30 31 DO 1ij = ijb+1, ije31 DO ij = ijb+1, ije 32 32 y( ij,l ) = ( rot( ij,l ) - rot( ij-1,l ) ) * cvsurcuv( ij ) 33 1 CONTINUE33 END DO 34 34 c 35 35 c ..... correction pour y ( 1,j,l ) ...... … … 37 37 c .... y(1,j,l)= y(iip1,j,l) .... 38 38 CDIR$ IVDEP 39 DO 2ij = ijb, ije, iip139 DO ij = ijb, ije, iip1 40 40 y( ij,l ) = y( ij +iim,l ) 41 2 CONTINUE41 END DO 42 42 c 43 43 ijb=ij_begin … … 47 47 if (pole_sud) ije=ij_end-iip1 48 48 49 DO 4ij = ijb,ije49 DO ij = ijb,ije 50 50 x( ij,l ) = ( rot( ij,l ) - rot( ij -iip1,l ) ) * cusurcvu( ij ) 51 4 CONTINUE51 END DO 52 52 53 53 if (pole_nord) then … … 63 63 endif 64 64 c 65 10 CONTINUE65 END DO 66 66 c$OMP END DO NOWAIT 67 67 RETURN -
LMDZ6/branches/Amaury_dev/libf/dyn3dmem/rotat_nfil_loc.F
r4593 r5086 33 33 if(pole_sud) ije=ij_end-iip1 34 34 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 35 DO 10l = 1,klevel35 DO l = 1,klevel 36 36 c 37 37 DO ij = ijb, ije - 1 … … 47 47 ENDDO 48 48 c 49 10 CONTINUE49 END DO 50 50 c$OMP END DO NOWAIT 51 51 RETURN -
LMDZ6/branches/Amaury_dev/libf/dyn3dmem/rotat_p.F
r4593 r5086 34 34 35 35 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 36 DO 10l = 1,klevel36 DO l = 1,klevel 37 37 c 38 38 DO ij = ijb, ije - 1 … … 48 48 ENDDO 49 49 c 50 10 CONTINUE50 END DO 51 51 c$OMP END DO NOWAIT 52 52 ccc CALL filtreg( rot, jjm, klevel, 2, 2, .FALSE., 1 ) -
LMDZ6/branches/Amaury_dev/libf/dyn3dmem/rotatf_loc.F
r4593 r5086 35 35 36 36 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 37 DO 10l = 1,klevel37 DO l = 1,klevel 38 38 c 39 39 DO ij = ijb, ije - 1 … … 49 49 ENDDO 50 50 c 51 10 CONTINUE51 END DO 52 52 c$OMP END DO NOWAIT 53 53 jjb=jj_begin -
LMDZ6/branches/Amaury_dev/libf/dynphy_lonlat/calfis.F
r5082 r5086 347 347 c ------------ 348 348 349 DO 50l=1,llm350 351 DO 25j=2,jjm349 DO l=1,llm 350 351 DO j=2,jjm 352 352 ig0 = 1+(j-2)*iim 353 353 zufi(ig0+1,l)= 0.5 * … … 355 355 pcvgu(ig0+1,l)= 0.5 * 356 356 $ ( pducov(iim,j,l)/cu(iim,j) + pducov(1,j,l)/cu(1,j) ) 357 DO 10i=2,iim357 DO i=2,iim 358 358 zufi(ig0+i,l)= 0.5 * 359 359 $ ( pucov(i-1,j,l)/cu(i-1,j) + pucov(i,j,l)/cu(i,j) ) 360 360 pcvgu(ig0+i,l)= 0.5 * 361 361 $ ( pducov(i-1,j,l)/cu(i-1,j) + pducov(i,j,l)/cu(i,j) ) 362 10 CONTINUE 363 25 CONTINUE 364 365 50 CONTINUE 362 END DO 363 END DO 364 365 END DO 366 366 367 367 -
LMDZ6/branches/Amaury_dev/libf/dynphy_lonlat/phylmd/test_disvert_m.F90
r2597 r5086 55 55 p(i, l + 1) / 100., " hPa" 56 56 end if 57 end do58 end do57 END DO 58 END DO 59 59 call abort_physic("test_disvert", "bad order of pressure values", 1) 60 60 end if -
LMDZ6/branches/Amaury_dev/libf/filtrez/eigen.F
r4593 r5086 10 10 im=iim 11 11 c 12 DO 48i = 1,im12 DO i = 1,im 13 13 asm( i ) = d( im-i+1 ) 14 48 CONTINUE15 DO 49i = 1,iim14 END DO 15 DO i = 1,iim 16 16 d( i ) = asm( i ) 17 49 CONTINUE17 END DO 18 18 c 19 19 c PRINT 70,d … … 21 21 print * 22 22 c 23 DO 51i = 1,im24 DO 52j = 1,im23 DO i = 1,im 24 DO j = 1,im 25 25 asm( j ) = e( i , im-j+1 ) 26 52 CONTINUE27 DO 50j = 1,im26 END DO 27 DO j = 1,im 28 28 e( i,j ) = asm( j ) 29 50 CONTINUE30 51 CONTINUE29 END DO 30 END DO 31 31 32 32 RETURN -
LMDZ6/branches/Amaury_dev/libf/misc/arth_m.F90
r2232 r5086 34 34 do k=2,n 35 35 arth_r(k)=arth_r(k-1)+increment 36 end do36 END DO 37 37 else 38 38 do k=2,NPAR2_ARTH 39 39 arth_r(k)=arth_r(k-1)+increment 40 end do40 END DO 41 41 temp=increment*NPAR2_ARTH 42 42 k=NPAR2_ARTH … … 47 47 temp=temp+temp 48 48 k=k2 49 end do49 END DO 50 50 end if 51 51 … … 68 68 do k=2,n 69 69 arth_i(k)=arth_i(k-1)+increment 70 end do70 END DO 71 71 else 72 72 do k=2,NPAR2_ARTH 73 73 arth_i(k)=arth_i(k-1)+increment 74 end do74 END DO 75 75 temp=increment*NPAR2_ARTH 76 76 k=NPAR2_ARTH … … 81 81 temp=temp+temp 82 82 k=k2 83 end do83 END DO 84 84 end if 85 85 -
LMDZ6/branches/Amaury_dev/libf/misc/chfev.F
r5082 r5086 124 124 C EVALUATION LOOP. 125 125 C 126 DO 500I = 1, NE126 DO I = 1, NE 127 127 X = XE(I) - X1 128 128 FE(I) = F1 + X*(D1 + X*(C2 + X*C3)) … … 131 131 IF ( X>XMA ) NEXT(2) = NEXT(2) + 1 132 132 C (NOTE REDUNDANCY--IF EITHER CONDITION IS TRUE, OTHER IS FALSE.) 133 500 CONTINUE133 END DO 134 134 C 135 135 C NORMAL RETURN. -
LMDZ6/branches/Amaury_dev/libf/misc/cray.F
r5081 r5086 36 36 ssum=ssum+sx(ix) 37 37 ix=ix+incx 38 end do38 END DO 39 39 c 40 40 return -
LMDZ6/branches/Amaury_dev/libf/misc/interpolation.F90
r1907 r5086 40 40 ju=jm ! or the upper limit, as appropriate. 41 41 end if 42 end do42 END DO 43 43 ! {ju == jl + 1} 44 44 … … 102 102 inc=inc+inc ! so double the increment 103 103 end if 104 end do! and try again.104 END DO ! and try again. 105 105 else ! Hunt down: 106 106 jhi=jlo … … 115 115 inc=inc+inc ! so double the increment 116 116 end if 117 end do! and try again.117 END DO ! and try again. 118 118 end if 119 119 end if ! Done hunting, value bracketed. … … 132 132 end if 133 133 end if 134 end do134 END DO 135 135 136 136 END SUBROUTINE hunt -
LMDZ6/branches/Amaury_dev/libf/misc/ismax.F
r5082 r5086 12 12 ismax=1 13 13 sxmax=sx(1) 14 do 10i=1,n-114 do i=1,n-1 15 15 ix=ix+incx 16 16 if(sx(ix)>sxmax) then … … 18 18 ismax=i+1 19 19 endif 20 10 continue 20 END DO 21 21 c 22 22 return -
LMDZ6/branches/Amaury_dev/libf/misc/new_unit_m.F90
r1907 r5086 19 19 if (exist .and. .not. opened) exit 20 20 unit = unit + 1 21 end do21 END DO 22 22 23 23 end subroutine new_unit -
LMDZ6/branches/Amaury_dev/libf/misc/pchdf.F
r5082 r5086 76 76 C COMPUTE COEFFICIENTS OF INTERPOLATING POLYNOMIAL. 77 77 C 78 DO 10J = 2, K-179 DO 9I = 1, K-J78 DO J = 2, K-1 79 DO I = 1, K-J 80 80 S(I) = (S(I+1)-S(I))/(X(I+J)-X(I)) 81 9 CONTINUE82 10 CONTINUE81 END DO 82 END DO 83 83 C 84 84 C EVALUATE DERIVATIVE AT X(K). 85 85 C 86 86 VALUE = S(1) 87 DO 20I = 2, K-187 DO I = 2, K-1 88 88 VALUE = S(I) + VALUE*(X(K)-X(I)) 89 20 CONTINUE89 END DO 90 90 C 91 91 C NORMAL RETURN. -
LMDZ6/branches/Amaury_dev/libf/misc/pchfe.F
r5082 r5086 145 145 IF ( N<2 ) GO TO 5001 146 146 IF ( INCFD<1 ) GO TO 5002 147 DO 1I = 2, N147 DO I = 2, N 148 148 IF ( X(I)<=X(I-1) ) GO TO 5003 149 1 CONTINUE149 END DO 150 150 C 151 151 C FUNCTION DEFINITION IS OK, GO ON. … … 168 168 C LOCATE ALL POINTS IN INTERVAL. 169 169 C 170 DO 20J = JFIRST, NE170 DO J = JFIRST, NE 171 171 IF (XE(J) >= X(IR)) GO TO 30 172 20 CONTINUE172 END DO 173 173 J = NE + 1 174 174 GO TO 40 … … 228 228 C 229 229 C FIRST, LOCATE FIRST POINT TO LEFT OF X(IR-1). 230 DO 44I = JFIRST, J-1230 DO I = JFIRST, J-1 231 231 IF (XE(I) < X(IR-1)) GO TO 45 232 44 CONTINUE232 END DO 233 233 C NOTE-- CANNOT DROP THROUGH HERE UNLESS THERE IS AN ERROR 234 234 C IN CHFEV. … … 240 240 C 241 241 C NOW FIND OUT HOW FAR TO BACK UP IN THE X-ARRAY. 242 DO 46I = 1, IR-1242 DO I = 1, IR-1 243 243 IF (XE(J) < X(I)) GO TO 47 244 46 CONTINUE244 END DO 245 245 C NB-- CAN NEVER DROP THROUGH HERE, SINCE XE(J).LT.X(IR-1). 246 246 C -
LMDZ6/branches/Amaury_dev/libf/misc/pchsp.F
r5082 r5086 164 164 IF ( N<2 ) GO TO 5001 165 165 IF ( INCFD<1 ) GO TO 5002 166 DO 1J = 2, N166 DO J = 2, N 167 167 IF ( X(J)<=X(J-1) ) GO TO 5003 168 1 CONTINUE168 END DO 169 169 C 170 170 IBEG = IC(1) … … 181 181 C COMPUTE FIRST DIFFERENCES OF X SEQUENCE AND STORE IN WK(1,.). ALSO, 182 182 C COMPUTE FIRST DIVIDED DIFFERENCE OF DATA AND STORE IN WK(2,.). 183 DO 5J=2,N183 DO J=2,N 184 184 WK(1,J) = X(J) - X(J-1) 185 185 WK(2,J) = (F(1,J) - F(1,J-1))/WK(1,J) 186 5 CONTINUE186 END DO 187 187 C 188 188 C SET TO DEFAULT BOUNDARY CONDITIONS IF N IS TOO SMALL. … … 197 197 ELSE IF (IBEG > 2) THEN 198 198 C PICK UP FIRST IBEG POINTS, IN REVERSE ORDER. 199 DO 10J = 1, IBEG199 DO J = 1, IBEG 200 200 INDEX = IBEG-J+1 201 201 C INDEX RUNS FROM IBEG DOWN TO 1. 202 202 XTEMP(J) = X(INDEX) 203 203 IF (J < IBEG) STEMP(J) = WK(2,INDEX) 204 10 CONTINUE204 END DO 205 205 C -------------------------------- 206 206 D(1,1) = PCHDF (IBEG, XTEMP, STEMP, IERR) … … 214 214 ELSE IF (IEND > 2) THEN 215 215 C PICK UP LAST IEND POINTS. 216 DO 15J = 1, IEND216 DO J = 1, IEND 217 217 INDEX = N-IEND+J 218 218 C INDEX RUNS FROM N+1-IEND UP TO N. 219 219 XTEMP(J) = X(INDEX) 220 220 IF (J < IEND) STEMP(J) = WK(2,INDEX+1) 221 15 CONTINUE221 END DO 222 222 C -------------------------------- 223 223 D(1,N) = PCHDF (IEND, XTEMP, STEMP, IERR) … … 267 267 NM1 = N-1 268 268 IF (NM1 > 1) THEN 269 DO 20J=2,NM1269 DO J=2,NM1 270 270 IF (WK(2,J-1) == ZERO) GO TO 5008 271 271 G = -WK(1,J+1)/WK(2,J-1) … … 273 273 * + THREE*(WK(1,J)*WK(2,J+1) + WK(1,J+1)*WK(2,J)) 274 274 WK(2,J) = G*WK(1,J-1) + TWO*(WK(1,J) + WK(1,J+1)) 275 20 CONTINUE275 END DO 276 276 ENDIF 277 277 C … … 324 324 C 325 325 30 CONTINUE 326 DO 40J=NM1,1,-1326 DO J=NM1,1,-1 327 327 IF (WK(2,J) == ZERO) GO TO 5008 328 328 D(1,J) = (D(1,J) - WK(1,J)*D(1,J+1))/WK(2,J) 329 40 CONTINUE329 END DO 330 330 C --------------------( END CODING FROM CUBSPL )-------------------- 331 331 C -
LMDZ6/branches/Amaury_dev/libf/misc/ran1.F
r5082 r5086 21 21 IX1=MOD(IA1*IX1+IC1,M1) 22 22 IX3=MOD(IX1,M3) 23 DO 11J=1,9723 DO J=1,97 24 24 IX1=MOD(IA1*IX1+IC1,M1) 25 25 IX2=MOD(IA2*IX2+IC2,M2) 26 26 R(J)=(REAL(IX1)+REAL(IX2)*RM2)*RM1 27 11 CONTINUE 27 END DO 28 28 IDUM=1 29 29 ENDIF -
LMDZ6/branches/Amaury_dev/libf/misc/regr1_step_av_m.F90
r3435 r5086 73 73 is = is + 1 74 74 left_edge = xs(is) 75 end do75 END DO 76 76 ! 1 <= is <= ns 77 77 vt(it) = (vt(it) + (xt(it + 1) - left_edge) * vs(is)) & … … 79 79 if (xs(is + 1) == xt(it + 1)) is = is + 1 80 80 ! 1 <= is <= ns .or. it == nt 81 end do81 END DO 82 82 83 83 end function regr11_step_av … … 133 133 is = is + 1 134 134 left_edge = xs(is) 135 end do135 END DO 136 136 ! 1 <= is <= ns 137 137 vt(it, :) = (vt(it, :) + (xt(it + 1) - left_edge) * vs(is, :)) & … … 139 139 if (xs(is + 1) == xt(it + 1)) is = is + 1 140 140 ! 1 <= is <= ns .or. it == nt 141 end do141 END DO 142 142 143 143 end function regr12_step_av … … 194 194 is = is + 1 195 195 left_edge = xs(is) 196 end do196 END DO 197 197 ! 1 <= is <= ns 198 198 vt(it, :, :) = (vt(it, :, :) & … … 200 200 if (xs(is + 1) == xt(it + 1)) is = is + 1 201 201 ! 1 <= is <= ns .or. it == nt 202 end do202 END DO 203 203 204 204 end function regr13_step_av … … 256 256 is = is + 1 257 257 left_edge = xs(is) 258 end do258 END DO 259 259 ! 1 <= is <= ns 260 260 vt(it, :, :, :) = (vt(it, :, :, :) + (xt(it + 1) - left_edge) & … … 262 262 if (xs(is + 1) == xt(it + 1)) is = is + 1 263 263 ! 1 <= is <= ns .or. it == nt 264 end do264 END DO 265 265 266 266 end function regr14_step_av -
LMDZ6/branches/Amaury_dev/libf/misc/xermsg.F
r5082 r5086 328 328 IF (LKNTRL > 0) THEN 329 329 WRITE (TEMP, '(''ERROR NUMBER = '', I8)') NERR 330 DO 10I=16,22330 DO I=16,22 331 331 IF (TEMP(I:I) /= ' ') GO TO 20 332 10 CONTINUE332 END DO 333 333 C 334 334 20 CALL XERPRN (' * ', -1, TEMP(1:15) // TEMP(I:23), 72) -
LMDZ6/branches/Amaury_dev/libf/misc/xerprn.F
r5082 r5086 92 92 C 93 93 N = I1MACH(4) 94 DO 10I=1,NUNIT94 DO I=1,NUNIT 95 95 IF (IU(I) == 0) IU(I) = N 96 10 CONTINUE96 END DO 97 97 C 98 98 C LPREF IS THE LENGTH OF THE PREFIX. THE PREFIX IS PLACED AT THE … … 117 117 LENMSG = LEN(MESSG) 118 118 N = LENMSG 119 DO 20I=1,N119 DO I=1,N 120 120 IF (MESSG(LENMSG:LENMSG) /= ' ') GO TO 30 121 121 LENMSG = LENMSG - 1 122 20 CONTINUE122 END DO 123 123 30 CONTINUE 124 124 C … … 127 127 IF (LENMSG == 0) THEN 128 128 CBUFF(LPREF+1:LPREF+1) = ' ' 129 DO 40I=1,NUNIT129 DO I=1,NUNIT 130 130 WRITE(IU(I), '(A)') CBUFF(1:LPREF+1) 131 40 CONTINUE131 END DO 132 132 RETURN 133 133 ENDIF … … 179 179 LPIECE = MIN(LWRAP, LENMSG+1-NEXTC) 180 180 IF (LPIECE < LENMSG+1-NEXTC) THEN 181 DO 52I=LPIECE+1,2,-1181 DO I=LPIECE+1,2,-1 182 182 IF (MESSG(NEXTC+I-1:NEXTC+I-1) == ' ') THEN 183 183 LPIECE = I-1 … … 185 185 GOTO 54 186 186 ENDIF 187 52 CONTINUE187 END DO 188 188 ENDIF 189 189 54 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) … … 202 202 IDELTA = 0 203 203 LPIECE = LWRAP 204 DO 56I=LPIECE+1,2,-1204 DO I=LPIECE+1,2,-1 205 205 IF (MESSG(NEXTC+I-1:NEXTC+I-1) == ' ') THEN 206 206 LPIECE = I-1 … … 208 208 GOTO 58 209 209 ENDIF 210 56 CONTINUE210 END DO 211 211 58 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) 212 212 NEXTC = NEXTC + LPIECE + IDELTA … … 223 223 C PRINT 224 224 C 225 DO 60I=1,NUNIT225 DO I=1,NUNIT 226 226 WRITE(IU(I), '(A)') CBUFF(1:LPREF+LPIECE) 227 60 CONTINUE227 END DO 228 228 C 229 229 IF (NEXTC <= LENMSG) GO TO 50 -
LMDZ6/branches/Amaury_dev/libf/misc/xersve.F
r5082 r5086 81 81 C 82 82 CALL XGETUA (LUN, NUNIT) 83 DO 20KUNIT = 1,NUNIT83 DO KUNIT = 1,NUNIT 84 84 IUNIT = LUN(KUNIT) 85 85 IF (IUNIT==0) IUNIT = I1MACH(4) … … 91 91 C Print body of table. 92 92 C 93 DO 10I = 1,NMSG93 DO I = 1,NMSG 94 94 WRITE (IUNIT,9010) LIBTAB(I), SUBTAB(I), MESTAB(I), 95 95 * NERTAB(I),LEVTAB(I),KOUNT(I) 96 10 CONTINUE96 END DO 97 97 C 98 98 C Print number of other errors. … … 100 100 IF (KOUNTX/=0) WRITE (IUNIT,9020) KOUNTX 101 101 WRITE (IUNIT,9030) 102 20 CONTINUE102 END DO 103 103 C 104 104 C Clear the error tables. … … 117 117 SUB = SUBROU 118 118 MES = MESSG 119 DO 30I = 1,NMSG119 DO I = 1,NMSG 120 120 IF (LIB==LIBTAB(I) .AND. SUB==SUBTAB(I) .AND. 121 121 * MES==MESTAB(I) .AND. NERR==NERTAB(I) .AND. … … 125 125 RETURN 126 126 ENDIF 127 30 CONTINUE127 END DO 128 128 C 129 129 IF (NMSG<LENTAB) THEN -
LMDZ6/branches/Amaury_dev/libf/misc/xgetua.F
r5082 r5086 45 45 C***FIRST EXECUTABLE STATEMENT XGETUA 46 46 N = J4SAVE(5,0,.FALSE.) 47 DO 30I=1,N47 DO I=1,N 48 48 INDEX = I+4 49 49 IF (I==1) INDEX = 3 50 50 IUNITA(I) = J4SAVE(INDEX,0,.FALSE.) 51 30 CONTINUE51 END DO 52 52 RETURN 53 53 END -
LMDZ6/branches/Amaury_dev/libf/obsolete/regr1_conserv_m.F90
r2788 r5086 97 97 vt(it) = vt(it) + (xs(is + 1) - xs(is)) * vs(is) 98 98 is = is + 1 99 end do99 END DO 100 100 ! 1 <= is <= ns 101 101 vt(it) = (vt(it) + mean_lin(xs(is), xt(it + 1)) * (xt(it + 1) & … … 105 105 if (xs(is + 1) == xt(it + 1)) is = is + 1 106 106 ! 1 <= is <= ns .or. it == nt 107 end do107 END DO 108 108 109 109 contains … … 170 170 vt(it, :) = vt(it, :) + (xs(is + 1) - xs(is)) * vs(is, :) 171 171 is = is + 1 172 end do172 END DO 173 173 ! 1 <= is <= ns 174 174 vt(it, :) = (vt(it, :) + mean_lin(xs(is), xt(it + 1)) * (xt(it + 1) & … … 178 178 if (xs(is + 1) == xt(it + 1)) is = is + 1 179 179 ! 1 <= is <= ns .or. it == nt 180 end do180 END DO 181 181 182 182 contains … … 246 246 vt(it, :, :) = vt(it, :, :) + (xs(is + 1) - xs(is)) * vs(is, :, :) 247 247 is = is + 1 248 end do248 END DO 249 249 ! 1 <= is <= ns 250 250 vt(it, :, :) = (vt(it, :, :) + mean_lin(xs(is), xt(it + 1)) & … … 254 254 if (xs(is + 1) == xt(it + 1)) is = is + 1 255 255 ! 1 <= is <= ns .or. it == nt 256 end do256 END DO 257 257 258 258 contains … … 324 324 * vs(is, :, :, :) 325 325 is = is + 1 326 end do326 END DO 327 327 ! 1 <= is <= ns 328 328 vt(it, :, :, :) = (vt(it, :, :, :) + mean_lin(xs(is), xt(it + 1)) & … … 332 332 if (xs(is + 1) == xt(it + 1)) is = is + 1 333 333 ! 1 <= is <= ns .or. it == nt 334 end do334 END DO 335 335 336 336 contains -
LMDZ6/branches/Amaury_dev/libf/obsolete/regr1_lint_m.F90
r2788 r5086 53 53 vt(it) = ((xs(is_b+1) - xt(it)) * vs(is_b) & 54 54 + (xt(it) - xs(is_b)) * vs(is_b+1)) / (xs(is_b+1) - xs(is_b)) 55 end do55 END DO 56 56 57 57 end function regr11_lint … … 92 92 vt(it, :) = ((xs(is_b+1) - xt(it)) * vs(is_b, :) & 93 93 + (xt(it) - xs(is_b)) * vs(is_b+1, :)) / (xs(is_b+1) - xs(is_b)) 94 end do94 END DO 95 95 96 96 end function regr12_lint -
LMDZ6/branches/Amaury_dev/libf/obsolete/regr1_step_av_m.F90
r2440 r5086 73 73 is = is + 1 74 74 left_edge = xs(is) 75 end do75 END DO 76 76 ! 1 <= is <= ns 77 77 vt(it) = (vt(it) + (xt(it + 1) - left_edge) * vs(is)) & … … 79 79 if (xs(is + 1) == xt(it + 1)) is = is + 1 80 80 ! 1 <= is <= ns .or. it == nt 81 end do81 END DO 82 82 83 83 end function regr11_step_av … … 133 133 is = is + 1 134 134 left_edge = xs(is) 135 end do135 END DO 136 136 ! 1 <= is <= ns 137 137 vt(it, :) = (vt(it, :) + (xt(it + 1) - left_edge) * vs(is, :)) & … … 139 139 if (xs(is + 1) == xt(it + 1)) is = is + 1 140 140 ! 1 <= is <= ns .or. it == nt 141 end do141 END DO 142 142 143 143 end function regr12_step_av … … 194 194 is = is + 1 195 195 left_edge = xs(is) 196 end do196 END DO 197 197 ! 1 <= is <= ns 198 198 vt(it, :, :) = (vt(it, :, :) & … … 200 200 if (xs(is + 1) == xt(it + 1)) is = is + 1 201 201 ! 1 <= is <= ns .or. it == nt 202 end do202 END DO 203 203 204 204 end function regr13_step_av … … 256 256 is = is + 1 257 257 left_edge = xs(is) 258 end do258 END DO 259 259 ! 1 <= is <= ns 260 260 vt(it, :, :, :) = (vt(it, :, :, :) + (xt(it + 1) - left_edge) & … … 262 262 if (xs(is + 1) == xt(it + 1)) is = is + 1 263 263 ! 1 <= is <= ns .or. it == nt 264 end do264 END DO 265 265 266 266 end function regr14_step_av -
LMDZ6/branches/Amaury_dev/libf/obsolete/regr3_lint_m.F90
r2788 r5086 53 53 vt(:, :, it) = ((xs(is_b+1) - xt(it)) * vs(:, :, is_b) & 54 54 + (xt(it) - xs(is_b)) * vs(:, :, is_b+1)) / (xs(is_b+1) - xs(is_b)) 55 end do55 END DO 56 56 57 57 end function regr33_lint … … 94 94 + (xt(it) - xs(is_b)) * vs(:, :, is_b+1, :)) & 95 95 / (xs(is_b+1) - xs(is_b)) 96 end do96 END DO 97 97 98 98 end function regr34_lint -
LMDZ6/branches/Amaury_dev/libf/obsolete/regr_lat_time_climoz_m.F90
r2788 r5086 249 249 do while (o3_in(j, 1, l, m) == missing_value) 250 250 j = j + 1 251 end do251 END DO 252 252 if (j > 1) o3_in(:j-1, :, l, m) = & 253 253 spread(o3_in(j, :, l, m), dim=1, ncopies=j-1) … … 257 257 do while (o3_in(j, 1, l, m) == missing_value) 258 258 j = j - 1 259 end do259 END DO 260 260 if (j < n_lat) o3_in(j+1:, :, l, m) = & 261 261 spread(o3_in(j, :, l, m), dim=1, ncopies=n_lat-j) … … 270 270 do while (o3_in(j, k, l, m) /= missing_value .and. k < n_plev) 271 271 k = k + 1 272 end do272 END DO 273 273 ! Replace missing values with the valid value at the 274 274 ! lowest level above missing values: 275 275 if (o3_in(j, k, l, m) == missing_value) & 276 276 o3_in(j, k:n_plev, l, m) = o3_in(j, k-1, l, m) 277 end do278 end do277 END DO 278 END DO 279 279 else 280 280 print *, "regr_lat_time_climoz: field ", m, & 281 281 ", no missing value attribute" 282 282 end if 283 end do283 END DO 284 284 285 285 call nf95_close(ncid_in) … … 322 322 call nf95_put_var(ncid_out, varid_out(m), o3_out(nbp_lat:1:-1, :, :, m)) 323 323 ! (The order of "rlatu" is inverted in the output file) 324 end do324 END DO 325 325 326 326 call nf95_close(ncid_out) -
LMDZ6/branches/Amaury_dev/libf/obsolete/regr_pr_av_m.F90
r2788 r5086 99 99 call handle_err("regr_pr_av nf90_get_var " // trim(name(i)), ncerr, & 100 100 ncid) 101 end do101 END DO 102 102 103 103 ! Latitudes are in ascending order in the input file while … … 118 118 slopes(v2(i, :, :), press_in_edg)) 119 119 ! (invert order of indices because "paprs" is in descending order) 120 end do120 END DO 121 121 122 122 end subroutine regr_pr_av -
LMDZ6/branches/Amaury_dev/libf/phylmd/Ocean_skin/bulk_flux_m.F90
r3834 r5086 140 140 rain = null_array, qcol = rnl + hf + hlb - dels) 141 141 end if 142 end do142 END DO 143 143 else 144 144 tkt = 0. -
LMDZ6/branches/Amaury_dev/libf/phylmd/StratAer/sulfate_aer_mod.F90
r5082 r5086 731 731 JX=0 732 732 ELSE 733 DO 10I=1,N733 DO I=1,N 734 734 IF (X<XC(I)) GO TO 20 735 10 CONTINUE735 END DO 736 736 IER=1 737 737 20 JX=I-1 … … 756 756 JX=0 757 757 ELSE 758 DO 10I=1,N758 DO I=1,N 759 759 IF (XT>X(I)) GO TO 20 760 10 CONTINUE760 END DO 761 761 20 JX=I 762 762 ENDIF -
LMDZ6/branches/Amaury_dev/libf/phylmd/concvl.F90
r4613 r5086 340 340 ! em_wght(k)=wght_th(i,k) 341 341 ! print*,'em_wght=',em_wght(k),wght_th(i,k) 342 ! end do342 ! END DO 343 343 ! END DO 344 344 -
LMDZ6/branches/Amaury_dev/libf/phylmd/cosp/icarus.F
r5082 r5086 364 364 enddo 365 365 366 do 12ilev=1,nlev366 do ilev=1,nlev 367 367 do j=1,npoints 368 368 if (pfull(j,ilev) < 40000. .and. … … 375 375 end if 376 376 enddo 377 12 continue 378 379 do 13ilev=1,nlev377 END DO 378 379 do ilev=1,nlev 380 380 do j=1,npoints 381 381 if (at(j,ilev) > atmax(j) .and. 382 382 & ilev >= itrop(j)) atmax(j)=at(j,ilev) 383 383 enddo 384 13 continue 384 END DO 385 385 386 386 end if … … 391 391 meantb(j) = 0. 392 392 meantbclr(j) = 0. 393 end do393 END DO 394 394 else 395 395 do j=1,npoints 396 396 meantb(j) = output_missing_value 397 397 meantbclr(j) = output_missing_value 398 end do398 END DO 399 399 end if 400 400 … … 466 466 467 467 !initialize tau and albedocld to zero 468 do 15ibox=1,ncol468 do ibox=1,ncol 469 469 do j=1,npoints 470 470 tau(j,ibox)=0. … … 474 474 box_cloudy(j,ibox)=.false. 475 475 enddo 476 15 continue 476 END DO 477 477 478 478 !compute total cloud optical depth for each column … … 541 541 if (ncolprint /= 0) 542 542 & write(6,*) 'ilev pw (kg/m2) tauwv(j) dem_wv' 543 do 125ilev=1,nlev543 do ilev=1,nlev 544 544 do j=1,npoints 545 545 !press and dpress are dyne/cm2 = Pascals *10 … … 568 568 enddo 569 569 endif 570 125 continue 570 END DO 571 571 572 572 !initialize variables … … 740 740 bb(j)=1/( exp(1307.27/skt(j)) - 1. ) 741 741 !bb(j)=5.67e-8*skt(j)**4 742 end do742 END DO 743 743 744 744 do ibox=1,ncol … … 751 751 & * trans_layers_above(j,ibox) 752 752 753 end do754 end do753 END DO 754 END DO 755 755 756 756 !calculate mean infrared brightness temperature … … 758 758 do j=1,npoints 759 759 meantb(j) = meantb(j)+1307.27/(log(1.+(1./fluxtop(j,ibox)))) 760 end do761 end do760 END DO 761 END DO 762 762 do j=1, npoints 763 763 meantb(j) = meantb(j) / real(ncol) 764 end do764 END DO 765 765 766 766 if (ncolprint/=0) then … … 784 784 write (6,'(8f7.2)') (meantb(j),ibox=1,ncolprint) 785 785 786 end do786 END DO 787 787 endif 788 788 … … 925 925 926 926 !compute cloud top pressure 927 do 30ibox=1,ncol927 do ibox=1,ncol 928 928 !segregate according to optical thickness 929 929 if (top_height == 1 .or. top_height == 3) then … … 933 933 nmatch(j)=0 934 934 enddo 935 do 29k1=1,nlev-1935 do k1=1,nlev-1 936 936 if (top_height_direction == 2) then 937 937 ilev = nlev - k1 … … 951 951 end if 952 952 enddo 953 29 continue 953 END DO 954 954 955 955 do j=1,npoints … … 992 992 levmatch(j,ibox)=ilev 993 993 end if 994 end do995 end do994 END DO 995 END DO 996 996 end if 997 997 … … 1003 1003 enddo 1004 1004 1005 30 continue 1005 END DO 1006 1006 1007 1007 ! … … 1032 1032 1033 1033 !reset frequencies 1034 do 38ilev=1,71034 do ilev=1,7 1035 1035 do 38 ilev2=1,7 1036 1036 do j=1,npoints ! … … 1042 1042 enddo 1043 1043 38 continue 1044 END DO 1044 1045 1045 1046 !reset variables need for averaging cloud properties … … 1060 1061 boxarea = 1./real(ncol) 1061 1062 1062 do 39ibox=1,ncol1063 do ibox=1,ncol 1063 1064 do j=1,npoints 1064 1065 … … 1166 1167 1167 1168 enddo ! j 1168 39 continue 1169 END DO 1169 1170 1170 1171 !compute mean cloud properties … … 1227 1228 & (cchar_realtops(acc(ilev,ibox)+1),ilev=1,nlev) 1228 1229 & ,(cchar(acc(ilev,ibox)+1),ilev=1,nlev) 1229 end do1230 END DO 1230 1231 close(9) 1231 1232 -
LMDZ6/branches/Amaury_dev/libf/phylmd/cosp/math_lib.F90
r5082 r5086 273 273 exit 274 274 end if 275 end do275 END DO 276 276 277 277 if (lerror) then … … 316 316 end if 317 317 ilo = ilo + 1 318 end do318 END DO 319 319 320 320 ilo = max ( 2, ilo ) … … 326 326 end if 327 327 ihi = ihi - 1 328 end do328 END DO 329 329 330 330 ihi = min ( ihi, ntab - 1 ) … … 374 374 syl = x2 375 375 376 end do376 END DO 377 377 378 378 result = sum1 & -
LMDZ6/branches/Amaury_dev/libf/phylmd/cosp/mod_cosp_modis_simulator.F90
r3233 r5086 176 176 opticalThickness(i, j, k) = 0. 177 177 end if 178 end do179 end do180 end do178 END DO 179 END DO 180 END DO 181 181 182 182 ! … … 197 197 do i = 1, nSunlit 198 198 if(subCols%frac_out(sunlit(i), j, k) == I_CVC) opticalThickness(i, j, k) = gridBox%dtau_c(sunlit(i), k) 199 end do200 end do201 end do199 END DO 200 END DO 201 END DO 202 202 203 203 ! … … 220 220 retrievedPhase(i, :), retrievedCloudTopPressure(i, :), & 221 221 retrievedTau(i, :), retrievedSize(i, :)) 222 end do222 END DO 223 223 224 224 ! DJS2015: Call L3 modis simulator used by cospv2.0 -
LMDZ6/branches/Amaury_dev/libf/phylmd/cosp/mod_modis_sim.F90
r5082 r5086 331 331 retrievedTau(i) = R_UNDEF 332 332 end if 333 end do333 END DO 334 334 where((retrievedSize(:) < 0.).and.(retrievedSize(:) /= R_UNDEF)) retrievedSize(:) = 1.0e-06*re_fill 335 335 … … 802 802 tauMask(:, :, i) = .false. 803 803 end where 804 end do804 END DO 805 805 806 806 do i = 1, numPressureHistogramBins … … 811 811 pressureMask(:, :, i) = .false. 812 812 end where 813 end do813 END DO 814 814 815 815 do i = 1, numPressureHistogramBins … … 817 817 Optical_Thickness_vs_Cloud_Top_Pressure(:, j, i) = & 818 818 real(count(tauMask(:, :, j) .and. pressureMask(:, :, i), dim = 2)) / real(nSubcols) 819 end do820 end do819 END DO 820 END DO 821 821 822 822 end subroutine modis_L3_simulator … … 851 851 end if 852 852 if(totalTau >= tauLimit) exit 853 end do853 END DO 854 854 cloud_top_pressure = totalProduct/totalTau 855 855 end function cloud_top_pressure … … 877 877 end if 878 878 if(totalTau >= tauLimit) exit 879 end do879 END DO 880 880 weight_by_extinction = totalProduct/totalTau 881 881 end function weight_by_extinction … … 1114 1114 do i = 1, size(cloudIndicies) 1115 1115 call two_stream(tau(cloudIndicies(i)), g(cloudIndicies(i)), w0(cloudIndicies(i)), Refl(i), Trans(i)) 1116 end do1116 END DO 1117 1117 1118 1118 call adding_doubling(Refl(:), Trans(:), Refl_tot, Trans_tot) … … 1292 1292 Refl_cumulative(i) = Refl_cumulative(i-1) + Refl(i)*(Tran_cumulative(i-1)**2)/(1 - Refl_cumulative(i-1) * Refl(i)) 1293 1293 Tran_cumulative(i) = (Tran_cumulative(i-1)*Tran(i)) / (1 - Refl_cumulative(i-1) * Refl(i)) 1294 end do1294 END DO 1295 1295 1296 1296 Refl_tot = Refl_cumulative(size(Refl)) -
LMDZ6/branches/Amaury_dev/libf/phylmd/cosp/optics_lib.F90
r5081 r5086 519 519 520 520 ! // region from 0.045 microns to 167.0 microns - no temperature depend 521 do i=2,nwl522 if(alam < wl(i)) continue523 enddo524 521 x1=log(wl(i-1)) 525 522 x2=log(wl(i)) … … 539 536 if(tk > temref(1)) tk=temref(1) 540 537 if(tk < temref(4)) tk=temref(4) 541 do 11i=2,4538 do i=2,4 542 539 if(tk>=temref(i)) go to 12 543 11 continue540 END DO 544 541 12 lt1=i 545 542 lt2=i-1 546 do 13i=2,nwlt543 do i=2,nwlt 547 544 if(alam<=wlt(i)) go to 14 548 13 continue545 END DO 549 546 14 x1=log(wlt(i-1)) 550 547 x2=log(wlt(i)) -
LMDZ6/branches/Amaury_dev/libf/phylmd/cosp/scops.F
r5082 r5086 161 161 162 162 !loop over vertical levels 163 DO 200ilev = 1,nlev163 DO ilev = 1,nlev 164 164 165 165 ! Initialise threshold … … 331 331 endif 332 332 333 200 CONTINUE!loop over nlev333 END DO !loop over nlev 334 334 335 335 -
LMDZ6/branches/Amaury_dev/libf/phylmd/cosp/zeff.F90
r5082 r5086 113 113 call mieint(sizep(i), m0(i), one, dqv, qext(i), dqsc, qbsca(i), & 114 114 dg, xs1, xs2, dph, err) 115 end do115 END DO 116 116 117 117 else -
LMDZ6/branches/Amaury_dev/libf/phylmd/cosp2/cosp.F90
r5082 r5086 731 731 modisRetrievedCloudTopPressure(i,:), & 732 732 modisRetrievedTau(i,:),modisRetrievedSize(i,:)) 733 end do733 END DO 734 734 endif 735 735 endif -
LMDZ6/branches/Amaury_dev/libf/phylmd/cosp2/icarus.F90
r5082 r5086 155 155 (cchar_realtops(acc(ilev,ibox)+1),ilev=1,nlev),& 156 156 (cchar(acc(ilev,ibox)+1),ilev=1,nlev) 157 end do157 END DO 158 158 close(9) 159 159 … … 322 322 do ibox=1,ncol 323 323 fluxtop(1:npoints,ibox) = fluxtop(1:npoints,ibox) + emsfc_lw*bb(1:npoints)*trans_layers_above(1:npoints,ibox) 324 end do324 END DO 325 325 326 326 ! All Sky brightness temperature … … 445 445 levmatch(1:npoints,ibox)=ilev 446 446 endwhere 447 end do447 END DO 448 448 end if 449 449 where(tau(1:npoints,ibox) <= tauchk) -
LMDZ6/branches/Amaury_dev/libf/phylmd/cosp2/math_lib.F90
r3358 r5086 209 209 exit 210 210 end if 211 end do211 END DO 212 212 213 213 if (lerror) then … … 244 244 end if 245 245 ilo = ilo + 1 246 end do246 END DO 247 247 248 248 ilo = max ( 2, ilo ) … … 254 254 end if 255 255 ihi = ihi - 1 256 end do256 END DO 257 257 258 258 ihi = min ( ihi, ntab - 1 ) … … 305 305 syl = x2 306 306 307 end do307 END DO 308 308 309 309 result = sum1 + ca * ( b**3 - syl**3 ) / 3._wp & -
LMDZ6/branches/Amaury_dev/libf/phylmd/cosp2/modis_simulator.F90
r3358 r5086 222 222 retrievedTau(i) = R_UNDEF 223 223 end if 224 end do224 END DO 225 225 where((retrievedSize(1:nSubCols) < 0.).and.(retrievedSize(1:nSubCols) /= R_UNDEF)) & 226 226 retrievedSize(1:nSubCols) = 1.0e-06_wp*re_fill … … 455 455 end if 456 456 if(totalTau >= tauLimit) exit 457 end do457 END DO 458 458 459 459 if (totalTau > 0._wp) then … … 489 489 end if 490 490 if(totalTau >= tauLimit) exit 491 end do491 END DO 492 492 493 493 if (totalTau > 0._wp) then … … 715 715 do i = 1, size(cloudIndicies) 716 716 call two_stream(tau(cloudIndicies(i)), g(cloudIndicies(i)), w0(cloudIndicies(i)), Refl(i), Trans(i)) 717 end do717 END DO 718 718 719 719 call adding_doubling(count(tau(1:nLevels) > 0),Refl(:), Trans(:), Refl_tot, Trans_tot) … … 897 897 Refl_cumulative(i) = Refl_cumulative(i-1) + Refl(i)*(Tran_cumulative(i-1)**2)/(1._wp - Refl_cumulative(i-1) * Refl(i)) 898 898 Tran_cumulative(i) = (Tran_cumulative(i-1)*Tran(i)) / (1._wp - Refl_cumulative(i-1) * Refl(i)) 899 end do899 END DO 900 900 901 901 Refl_tot = Refl_cumulative(size(Refl)) -
LMDZ6/branches/Amaury_dev/libf/phylmd/cosp2/optics_lib.F90
r5082 r5086 539 539 if (alam < cutice) then 540 540 ! Region from 0.045 microns to 167.0 microns - no temperature depend 541 do i=2,nwl542 if(alam < wl(i)) continue543 enddo544 541 x1 = log(wl(i-1)) 545 542 x2 = log(wl(i)) -
LMDZ6/branches/Amaury_dev/libf/phylmd/cosp2/quickbeam_optics.F90
r5082 r5086 1009 1009 call mieint(sizep(i), m0(i), one, dqv, qext(i), dqsc, qbsca(i), & 1010 1010 dg, xs1, xs2, dph, err) 1011 end do1011 END DO 1012 1012 1013 1013 else -
LMDZ6/branches/Amaury_dev/libf/phylmd/cospv2/cosp.F90
r5082 r5086 886 886 modisRetrievedCloudTopPressure(i,:), & 887 887 modisRetrievedTau(i,:),modisRetrievedSize(i,:)) 888 end do888 END DO 889 889 endif 890 890 endif -
LMDZ6/branches/Amaury_dev/libf/phylmd/cospv2/icarus.F90
r5082 r5086 155 155 (cchar_realtops(acc(ilev,ibox)+1),ilev=1,nlev),& 156 156 (cchar(acc(ilev,ibox)+1),ilev=1,nlev) 157 end do157 END DO 158 158 close(9) 159 159 … … 322 322 do ibox=1,ncol 323 323 fluxtop(1:npoints,ibox) = fluxtop(1:npoints,ibox) + emsfc_lw*bb(1:npoints)*trans_layers_above(1:npoints,ibox) 324 end do324 END DO 325 325 326 326 ! All Sky brightness temperature … … 445 445 levmatch(1:npoints,ibox)=ilev 446 446 endwhere 447 end do447 END DO 448 448 end if 449 449 where(tau(1:npoints,ibox) <= tauchk) -
LMDZ6/branches/Amaury_dev/libf/phylmd/cospv2/lmdz_cosp_subsample_and_optics_mod.F90
r5082 r5086 365 365 endif 366 366 cospIN%g_vol_cloudsat(i,:,j)=g_vol(i,j) 367 end do368 end do367 END DO 368 END DO 369 369 370 370 ! Loop over all subcolumns -
LMDZ6/branches/Amaury_dev/libf/phylmd/cospv2/math_lib.F90
r3491 r5086 209 209 exit 210 210 end if 211 end do211 END DO 212 212 213 213 if (lerror) then … … 244 244 end if 245 245 ilo = ilo + 1 246 end do246 END DO 247 247 248 248 ilo = max ( 2, ilo ) … … 254 254 end if 255 255 ihi = ihi - 1 256 end do256 END DO 257 257 258 258 ihi = min ( ihi, ntab - 1 ) … … 305 305 syl = x2 306 306 307 end do307 END DO 308 308 309 309 result = sum1 + ca * ( b**3 - syl**3 ) / 3._wp & -
LMDZ6/branches/Amaury_dev/libf/phylmd/cospv2/modis_simulator.F90
r3491 r5086 222 222 retrievedTau(i) = R_UNDEF 223 223 end if 224 end do224 END DO 225 225 where((retrievedSize(1:nSubCols) < 0.).and.(retrievedSize(1:nSubCols) /= R_UNDEF)) & 226 226 retrievedSize(1:nSubCols) = 1.0e-06_wp*re_fill … … 455 455 end if 456 456 if(totalTau >= tauLimit) exit 457 end do457 END DO 458 458 459 459 if (totalTau > 0._wp) then … … 489 489 end if 490 490 if(totalTau >= tauLimit) exit 491 end do491 END DO 492 492 493 493 if (totalTau > 0._wp) then … … 715 715 do i = 1, size(cloudIndicies) 716 716 call two_stream(tau(cloudIndicies(i)), g(cloudIndicies(i)), w0(cloudIndicies(i)), Refl(i), Trans(i)) 717 end do717 END DO 718 718 719 719 call adding_doubling(count(tau(1:nLevels) > 0),Refl(:), Trans(:), Refl_tot, Trans_tot) … … 897 897 Refl_cumulative(i) = Refl_cumulative(i-1) + Refl(i)*(Tran_cumulative(i-1)**2)/(1._wp - Refl_cumulative(i-1) * Refl(i)) 898 898 Tran_cumulative(i) = (Tran_cumulative(i-1)*Tran(i)) / (1._wp - Refl_cumulative(i-1) * Refl(i)) 899 end do899 END DO 900 900 901 901 Refl_tot = Refl_cumulative(size(Refl)) -
LMDZ6/branches/Amaury_dev/libf/phylmd/cospv2/optics_lib.F90
r5081 r5086 539 539 if (alam < cutice) then 540 540 ! Region from 0.045 microns to 167.0 microns - no temperature depend 541 do i=2,nwl542 if(alam < wl(i)) continue543 enddo544 541 x1 = log(wl(i-1)) 545 542 x2 = log(wl(i)) -
LMDZ6/branches/Amaury_dev/libf/phylmd/cospv2/quickbeam_optics.F90
r5081 r5086 983 983 call mieint(sizep(i), m0(i), one, dqv, qext(i), dqsc, qbsca(i), & 984 984 dg, xs1, xs2, dph, err) 985 end do985 END DO 986 986 987 987 else -
LMDZ6/branches/Amaury_dev/libf/phylmd/cv30_routines.F90
r5082 r5086 1548 1548 ! !!! traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k) 1549 1549 ! !!! : +(1.-sij(il,i,j))*tra(il,nk(il),k) 1550 ! !!! end do1550 ! !!! END DO 1551 1551 elij(il, i, j) = altem 1552 1552 elij(il, i, j) = amax1(0.0, elij(il,i,j)) … … 2144 2144 ! : +tra(il,i,j)*(mp(il,i)-mp(il,i+1)) 2145 2145 ! trap(il,i,j)=trap(il,i,j)/mp(il,i) 2146 ! end do2146 ! END DO 2147 2147 2148 2148 ELSE … … 2161 2161 ! do j=1,ntra 2162 2162 ! trap(il,i,j)=trap(il,i+1,j) 2163 ! end do2163 ! END DO 2164 2164 2165 2165 END IF -
LMDZ6/branches/Amaury_dev/libf/phylmd/cv3_routines.F90
r5082 r5086 2431 2431 !!!! traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k) 2432 2432 !!!! : +(1.-sij(il,i,j))*tra(il,nk(il),k) 2433 !!!! end do2433 !!!! END DO 2434 2434 elij(il, i, j) = altem 2435 2435 elij(il, i, j) = max(0.0, elij(il,i,j)) … … 3424 3424 !AC! endif ! (i.lt.inb(il) .and. lwork(il)) 3425 3425 !AC! enddo 3426 !AC! end do3426 !AC! END DO 3427 3427 3428 3428 400 END DO -
LMDZ6/branches/Amaury_dev/libf/phylmd/dyn1d/old_1DUTILS_read_interp.h
r5075 r5086 2010 2010 read (ilesfile,*) height(k),ugprof(k),vgprof(k),wfls(k), & 2011 2011 & dqtdxls(k),dqtdyls(k),dqtdtls(k),thlpcar(k) 2012 end do2012 END DO 2013 2013 do k=1,kmax 2014 2014 if (height(k) .ne. height1(k)) then … … 2017 2017 stop 2018 2018 endif 2019 end do2019 END DO 2020 2020 close(ilesfile) 2021 2021 … … 2035 2035 do k=1,kmax 2036 2036 read (ilesfile,*) height(k),(tracer(k,itrac),itrac=nt1,nt2) 2037 end do2037 END DO 2038 2038 close(ilesfile) 2039 2039 endif -
LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/surf_inlandsis_mod.F90
r5075 r5086 470 470 depth = depth - dzsnSV(ikl,isl) / 2. 471 471 472 end do472 END DO 473 473 474 474 END DO -
LMDZ6/branches/Amaury_dev/libf/phylmd/isccp_cloud_types.F90
r1992 r5086 1027 1027 ! write (6,'(a)') '100.*f:' 1028 1028 ! write (6,'(8f7.2)') (100.*fluxtop(j,ibox),ibox=1,ncolprint) 1029 ! end do1029 ! END DO 1030 1030 ! endif 1031 1031 … … 1569 1569 ! & (cchar_realtops(acc(ilev,ibox)+1),ilev=1,nlev) 1570 1570 ! & ,(cchar(acc(ilev,ibox)+1),ilev=1,nlev) 1571 ! end do1571 ! END DO 1572 1572 ! close(9) 1573 1573 -
LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_wake.F90
r4908 r5086 1507 1507 ! c do i=1,klon 1508 1508 ! c print*,alpha(i) 1509 ! c end do1509 ! c END DO 1510 1510 ! cc 1511 1511 DO k = 1, klev -
LMDZ6/branches/Amaury_dev/libf/phylmd/o3_chem_m.F90
r4103 r5086 24 24 25 25 integer, intent(in):: julien ! jour julien, 1 <= julien <= 360 26 real, intent(in):: gmtime ! heure de la journ ée en fraction de jour26 real, intent(in):: gmtime ! heure de la journ�e en fraction de jour 27 27 real, intent(in):: t_seri(:, :) ! (klon, nbp_lev) temperature, in K 28 28 … … 59 59 real earth_long 60 60 ! (longitude vraie de la Terre dans son orbite solaire, par 61 ! rapport au point vernal (21 mars), en degr és)61 ! rapport au point vernal (21 mars), en degr�s) 62 62 63 63 real pmu0(klon) ! mean of cosine of solar zenith angle during "pdtphys" … … 163 163 do k = nbp_lev - 1, 1, -1 164 164 sigma_mass(:, k) = sigma_mass(:, k+1) + zmasse(:, k) * q(:, k) 165 end do165 END DO 166 166 167 167 o3_prod = c + b * q + a6_mass * sigma_mass -
LMDZ6/branches/Amaury_dev/libf/phylmd/phyetat0_mod.F90
r5075 r5086 321 321 IF (.NOT. found) THEN 322 322 PRINT*, "phyetat0: Le champ <Tsoil"//str7//"> est absent" 323 PRINT*, " Il pr end donc la valeur de surface"323 PRINT*, " Il prEND DOnc la valeur de surface" 324 324 tsoil(:, isoil, :)=ftsol(:, :) 325 325 ENDIF -
LMDZ6/branches/Amaury_dev/libf/phylmd/physiq_mod.F90
r5082 r5086 1705 1705 998 CONTINUE 1706 1706 CLOSE(98) 1707 CONTINUE1708 1707 IF(nCFMIP>npCFMIP) THEN 1709 1708 print*,'nCFMIP > npCFMIP : augmenter npCFMIP et recompiler' -
LMDZ6/branches/Amaury_dev/libf/phylmd/regr_lat_time_coefoz_m.F90
r5075 r5086 182 182 do i_v = 1, n_o3_param 183 183 call nf95_inq_varid(ncid_in, trim(name_in(i_v)), varid_in(i_v)) 184 end do184 END DO 185 185 186 186 ! Create the output file and get the variable IDs: … … 225 225 o3_par_out(nbp_lat:1:-1, :, :)) 226 226 ! (The order of "rlatu" is inverted in the output file) 227 end do227 END DO 228 228 229 229 call nf95_close(ncid_out) … … 309 309 & varid_out(i)) 310 310 call handle_err_copy_att("standard_name") 311 end do311 END DO 312 312 313 313 ! Global attributes: -
LMDZ6/branches/Amaury_dev/libf/phylmd/regr_pr_int_m.F90
r4489 r5086 98 98 v3(i, nbp_lev:1:-1)) 99 99 ! (invert order of indices because "pplay" is in descending order) 100 end do100 END DO 101 101 102 102 end subroutine regr_pr_int -
LMDZ6/branches/Amaury_dev/libf/phylmd/regr_pr_o3_m.F90
r5075 r5086 77 77 p3d(1, j, nbp_lev + 1:1:-1), o3_mob_regr(1, j, nbp_lev:1:-1)) 78 78 ! (invert order of indices because "p3d" is in descending order) 79 end do79 END DO 80 80 81 81 ! Other latitudes: … … 85 85 p3d(i, j, nbp_lev + 1:1:-1), o3_mob_regr(i, j, nbp_lev:1:-1)) 86 86 ! (invert order of indices because "p3d" is in descending order) 87 end do88 end do87 END DO 88 END DO 89 89 90 90 ! Duplicate pole values on all longitudes: -
LMDZ6/branches/Amaury_dev/libf/phylmd/rrtm/dump2ds.F
r5082 r5086 27 27 REAL zmin,zmax,zllu,zllm 28 28 write(F1000,'(''(4x,'',I3,''(1H-))'')')im+3 29 DO 10001i=1,20029 DO i=1,200 30 30 jline(1+(i-1)*5:5*i)='. ' 31 10001 CONTINUE 31 END DO 32 32 10002 zmin=z(1,1) 33 33 imin=1 … … 37 37 jmax=1 38 38 kzero=0 39 DO 10003j=1,jm40 DO 10005i=1,im39 DO j=1,jm 40 DO i=1,im 41 41 IF(.NOT.( z(i,j)>zmax))GOTO 10007 42 42 zmax=z(i,j) … … 50 50 kzero=kzero+1 51 51 10011 CONTINUE 52 10005 CONTINUE 52 END DO 53 53 10006 CONTINUE 54 10003 CONTINUE 54 END DO 55 55 10004 zsign=(sign(1.,zmin)*sign(1.,zmax)>0.) 56 56 WRITE(*,*)'>>> dump2ds: ',trim(nom_z) … … 73 73 zinf=.false. 74 74 znan=.false. 75 DO 10017j=1,jm76 DO 10019i=1,im75 DO j=1,jm 76 DO i=1,im 77 77 az=abs(z(i,j)) 78 78 IF(.NOT.( az==0.))GOTO 10021 … … 97 97 kchar(i)=32-kchar(i) 98 98 10027 CONTINUE 99 10019 CONTINUE 99 END DO 100 100 10020 WRITE(*,'(1x,i3,''|'',1000a)')j+1,(iform(kchar(i)),i=1,im),'|','| 101 101 *' 102 10017 CONTINUE 102 END DO 103 103 10018 write(*,F1000) 104 104 WRITE(*,'(5x,1000i1)')(mod(i,10),i=1,im) -
LMDZ6/branches/Amaury_dev/libf/phylmd/rrtm/eq_regions_mod.F90
r5082 r5086 353 353 do k = 2, n 354 354 w = w * (x - k) 355 end do355 END DO 356 356 else 357 357 w = 1 358 358 do k = 0, -n - 1 359 359 y = y * (x + k) 360 end do360 END DO 361 361 end if 362 362 gamma_res = w / y -
LMDZ6/branches/Amaury_dev/libf/phylmd/rrtm/set99.F
r5082 r5086 15 15 NIL=0 16 16 NHL=(N/2)-1 17 DO 10K=NIL,NHL17 DO K=NIL,NHL 18 18 ANGLE=FLOAT(K)*DEL 19 19 TRIGS(2*K+1)=COS(ANGLE) 20 20 TRIGS(2*K+2)=SIN(ANGLE) 21 10 CONTINUE21 END DO 22 22 C 23 23 C FIND FACTORS OF N (8,6,5,4,3,2; ONLY ONE 8 ALLOWED) -
LMDZ6/branches/Amaury_dev/libf/phylmd/simu_airs.F90
r5082 r5086 30 30 do i=1,N-1 31 31 slope(i)=-(T(i+1)-T(i))/(alt(i+1)-alt(i)) 32 end do32 END DO 33 33 slope(N)=slope(N-1) 34 34 … … 60 60 i=i+i_dir 61 61 if (i<=1.or.i>=N) exit_flag=1 62 end do62 END DO 63 63 64 64 if (first_point<=0) P_tropo=65.4321 -
LMDZ6/branches/Amaury_dev/libf/phylmdiso/concvl.F90
r4613 r5086 415 415 ! em_wght(k)=wght_th(i,k) 416 416 ! print*,'em_wght=',em_wght(k),wght_th(i,k) 417 ! end do417 ! END DO 418 418 ! END DO 419 419 -
LMDZ6/branches/Amaury_dev/libf/phylmdiso/cv30_routines.F90
r4491 r5086 2032 2032 ! !!! traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k) 2033 2033 ! !!! : +(1.-sij(il,i,j))*tra(il,nk(il),k) 2034 ! !!! end do2034 ! !!! END DO 2035 2035 elij(il, i, j) = altem 2036 2036 elij(il, i, j) = amax1(0.0, elij(il,i,j)) … … 3155 3155 ! : +tra(il,i,j)*(mp(il,i)-mp(il,i+1)) 3156 3156 ! trap(il,i,j)=trap(il,i,j)/mp(il,i) 3157 ! end do3157 ! END DO 3158 3158 3159 3159 ELSE … … 3172 3172 ! do j=1,ntra 3173 3173 ! trap(il,i,j)=trap(il,i+1,j) 3174 ! end do3174 ! END DO 3175 3175 3176 3176 END IF -
LMDZ6/branches/Amaury_dev/libf/phylmdiso/cv3_routines.F90
r5082 r5086 2965 2965 !!!! traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k) 2966 2966 !!!! : +(1.-sij(il,i,j))*tra(il,nk(il),k) 2967 !!!! end do2967 !!!! END DO 2968 2968 elij(il, i, j) = altem 2969 2969 elij(il, i, j) = max(0.0, elij(il,i,j)) … … 4485 4485 !AC! endif ! (i.lt.inb(il) .and. lwork(il)) 4486 4486 !AC! enddo 4487 !AC! end do4487 !AC! END DO 4488 4488 4489 4489 #ifdef ISO -
LMDZ6/branches/Amaury_dev/libf/phylmdiso/lmdz_wake.F90
r4594 r5086 127 127 ! wdens_ref: initial number of wakes per unit area (3D) or per 128 128 ! unit length (2D), at the beginning of each time step 129 ! Tgw : 1 sur la p ériode de onde de gravité130 ! Cgw : vitesse de propagation de onde de gravit é129 ! Tgw : 1 sur la p�riode de onde de gravit� 130 ! Cgw : vitesse de propagation de onde de gravit� 131 131 ! LL : distance entre 2 poches 132 132 133 133 ! ------------------------------------------------------------------------- 134 ! D éclaration de variables134 ! D�claration de variables 135 135 ! ------------------------------------------------------------------------- 136 136 … … 196 196 ! ------------------- 197 197 198 ! Variables àfixer198 ! Variables � fixer 199 199 INTEGER, SAVE :: igout 200 200 !$OMP THREADPRIVATE(igout) … … 383 383 ! Configuration de coefgw,stark,wdens (22/02/06 by YU Jingmei) 384 384 385 ! coefgw : Coefficient pour les ondes de gravit é385 ! coefgw : Coefficient pour les ondes de gravit� 386 386 ! stark : Coefficient k dans Cstar=k*sqrt(2*WAPE) 387 ! wdens : Densit ésurfacique de poche froide387 ! wdens : Densit� surfacique de poche froide 388 388 ! ------------------------------------------------------------------------- 389 389 … … 1088 1088 1089 1089 ! cc nrlmd Ajout d'un recalcul de wdens dans le cas d'un entrainement 1090 ! n égatif de ktop àkupper --------1091 ! cc On calcule pour cela une densit éwdens0 pour laquelle on1090 ! n�gatif de ktop � kupper -------- 1091 ! cc On calcule pour cela une densit� wdens0 pour laquelle on 1092 1092 ! aurait un entrainement nul --- 1093 1093 !jyg< … … 1096 1096 ! des descentes unsaturees. Nous faisons alors l'hypothese que la 1097 1097 ! convection profonde cree directement de nouvelles poches, sans passer 1098 ! par les thermiques. La nouvelle valeur de wdens est alors impos ée.1098 ! par les thermiques. La nouvelle valeur de wdens est alors impos�e. 1099 1099 1100 1100 DO i = 1, klon … … 1195 1195 DO i = 1, klon 1196 1196 IF (wk_adv(i)) THEN 1197 ! cc nrlmd Introduction du taux de mortalit édes poches et1197 ! cc nrlmd Introduction du taux de mortalit� des poches et 1198 1198 ! test sur sigmaw_max=0.4 1199 1199 ! cc d_sigmaw(i) = gfl(i)*Cstar(i)*dtimesub … … 1308 1308 1309 1309 ! c DO i=1,klon 1310 ! c print*,'Pente entre 0 et kupper (r éférence)'1310 ! c print*,'Pente entre 0 et kupper (r�f�rence)' 1311 1311 ! c $ ,omg(i,kupper(i)+1)/(pupper(i)-ph(i,1)) 1312 1312 ! c print*,'Pente entre ktop et kupper' … … 1602 1602 1603 1603 1604 ! Coefficient de r épartition1604 ! Coefficient de r�partition 1605 1605 1606 1606 crep(i, k) = crep_sol*(ph(i,kupper(i))-ph(i,k))/ & … … 1646 1646 ! 1647 1647 1648 ! cc nrlmd Prise en compte du taux de mortalit é1649 ! cc D éfinitions de entr, detr1648 ! cc nrlmd Prise en compte du taux de mortalit� 1649 ! cc D�finitions de entr, detr 1650 1650 !jyg< 1651 1651 !! detr(i, k) = 0. … … 1664 1664 1665 1665 1666 ! ajout d'un effet onde de gravit é-Tgw(k)*deltatw(k) 03/02/06 YU1666 ! ajout d'un effet onde de gravit� -Tgw(k)*deltatw(k) 03/02/06 YU 1667 1667 ! Jingmei 1668 1668 … … 1748 1748 ! c do i=1,klon 1749 1749 ! c print*,alpha(i) 1750 ! c end do1750 ! c END DO 1751 1751 ! cc 1752 1752 DO k = 1, klev … … 2601 2601 discrim = b*b - 4.*a*c 2602 2602 ! print*, 'x, a, b, c, discrim', x, a, b, c, discrim 2603 IF (a+b>=0.) THEN !! Condition suffisante pour la positivit éde ovap2603 IF (a+b>=0.) THEN !! Condition suffisante pour la positivit� de ovap 2604 2604 alpha1(i) = 1. 2605 2605 ELSE -
LMDZ6/branches/Amaury_dev/libf/phylmdiso/phyetat0_mod.F90
r5082 r5086 342 342 IF (.NOT. found) THEN 343 343 PRINT*, "phyetat0: Le champ <Tsoil"//str7//"> est absent" 344 PRINT*, " Il pr end donc la valeur de surface"344 PRINT*, " Il prEND DOnc la valeur de surface" 345 345 tsoil(:, isoil, :)=ftsol(:, :) 346 346 ENDIF -
LMDZ6/branches/Amaury_dev/libf/phylmdiso/physiq_mod.F90
r5082 r5086 1869 1869 998 CONTINUE 1870 1870 CLOSE(98) 1871 CONTINUE1872 1871 IF(nCFMIP>npCFMIP) THEN 1873 1872 print*,'nCFMIP > npCFMIP : augmenter npCFMIP et recompiler' -
LMDZ6/branches/Amaury_dev/tools/netcdf95/Datasets/nf95_create_single.f90
r5075 r5086 47 47 call nf95_put_att(ncid, varid_coord(i), coordinates(i)%attr_name(j), & 48 48 coordinates(i)%attr_val(j)) 49 end do50 end do49 END DO 50 END DO 51 51 52 52 call nf95_def_var(ncid, name, NF90_FLOAT, dimids, varid) -
LMDZ6/branches/Amaury_dev/tools/netcdf95/Datasets/nf95_find_coord.f90
r5075 r5086 96 96 end if 97 97 end if 98 end do98 END DO 99 99 100 100 if (found) then -
LMDZ6/branches/Amaury_dev/tools/netcdf95/Groups/nf95_inq_file_ncid.f90
r5075 r5086 31 31 if (ncerr_local /= nf95_noerr) exit 32 32 ncid_file = parent_ncid 33 end do33 END DO 34 34 35 35 if (ncerr_local == NF95_ENOGRP) then -
LMDZ6/branches/Amaury_dev/tools/netcdf95/Variables/nf95_gw_var.f90
r4918 r5086 152 152 do i = 1, 4 153 153 call nf95_inquire_dimension(ncid, dimids(i), nclen=len_dim(i)) 154 end do154 END DO 155 155 156 156 allocate(values(len_dim(1), len_dim(2), len_dim(3), len_dim(4))) … … 186 186 do i = 1, 5 187 187 call nf95_inquire_dimension(ncid, dimids(i), nclen=len_dim(i)) 188 end do188 END DO 189 189 190 190 allocate(values(len_dim(1), len_dim(2), len_dim(3), len_dim(4), len_dim(5))) … … 323 323 do i = 1, 4 324 324 call nf95_inquire_dimension(ncid, dimids(i), nclen=len_dim(i)) 325 end do325 END DO 326 326 327 327 allocate(values(len_dim(1), len_dim(2), len_dim(3), len_dim(4)))
Note: See TracChangeset
for help on using the changeset viewer.