Ignore:
Timestamp:
Aug 2, 2024, 2:12:03 PM (4 months ago)
Author:
abarral
Message:

Add missing klon on strataer_emiss_mod.F90
Correct various missing explicit declarations
Replace tabs by spaces (tabs are not part of the fortran charset)
Continue cleaning modules
Removed unused arguments and variables

Location:
LMDZ6/branches/Amaury_dev/libf/dyn3d_common
Files:
32 edited

Legend:

Unmodified
Added
Removed

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/adaptdt.f90

    r5136 r5158  
    2929
    3030    CFLmax=0.
    31     do l=1,llm
    32      do j=2,jjm
    33       do i=1,iim
     31    DO l=1,llm
     32     DO j=2,jjm
     33      DO i=1,iim
    3434         aaa=pbaru(i,j,l)*dtvr/masse(i,j,l)
    3535         CFLmax=max(CFLmax,aaa)

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/advn.f90

    r5136 r5158  
    7575  ENDDO
    7676
    77   do l = 1, llm
     77  DO l = 1, llm
    7878    qpn = 0.
    7979    qps = 0.
    80     do ij = 1, iim
     80    DO ij = 1, iim
    8181      qpn = qpn + q(ij, l) * masse(ij, l)
    8282      qps = qps + q(ip1jm + ij, l) * masse(ip1jm + ij, l)
    … …  
    8484    qpn = qpn / ssum(iim, masse(1, l), 1)
    8585    qps = qps / ssum(iim, masse(ip1jm + 1, l), 1)
    86     do ij = 1, iip1
     86    DO ij = 1, iip1
    8787      q(ij, l) = qpn
    8888      q(ip1jm + ij, l) = qps
    … …  
    9090  enddo
    9191
    92   do ij = 1, ip1jmp1
     92  DO ij = 1, ip1jmp1
    9393    mw(ij, llm + 1) = 0.
    9494  enddo
    95   do l = 1, llm
    96     do ij = 1, ip1jmp1
     95  DO l = 1, llm
     96    DO ij = 1, ip1jmp1
    9797      zq(ij, l) = q(ij, l)
    9898      zm(ij, l) = masse(ij, l)
    … …  
    114114  ! CALL minmaxq(zq,qmin,qmax,'apres vlx     ')
    115115
    116   do l = 1, llm
    117     do ij = 1, ip1jmp1
     116  DO l = 1, llm
     117    DO ij = 1, ip1jmp1
    118118      q(ij, l) = zq(ij, l)
    119119    enddo
    120     do ij = 1, ip1jm + 1, iip1
     120    DO ij = 1, ip1jm + 1, iip1
    121121      q(ij + iim, l) = q(ij, l)
    122122    enddo
    … …  
    158158  !   -----------------------
    159159  IF (mode==0) THEN
    160     do l = 1, llm
    161       do ij = 1, ip1jm
     160    DO l = 1, llm
     161      DO ij = 1, ip1jm
    162162        qd(ij, l) = q(ij, l)
    163163        qg(ij, l) = q(ij, l)
    … …  
    165165    enddo
    166166  else
    167     do l = 1, llm
    168       do ij = iip2, ip1jm - 1
     167    DO l = 1, llm
     168      DO ij = iip2, ip1jm - 1
    169169        dxqu(ij) = q(ij + 1, l) - q(ij, l)
    170170        zqu(ij) = 0.5 * (q(ij + 1, l) + q(ij, l))
    171171      enddo
    172       do ij = iip1 + iip1, ip1jm, iip1
     172      DO ij = iip1 + iip1, ip1jm, iip1
    173173        dxqu(ij) = dxqu(ij - iim)
    174174        zqu(ij) = zqu(ij - iim)
    175175      enddo
    176       do ij = iip2, ip1jm - 1
     176      DO ij = iip2, ip1jm - 1
    177177        zqu(ij) = zqu(ij) - dxqu(ij + 1) / 12.
    178178      enddo
    179       do ij = iip1 + iip1, ip1jm, iip1
     179      DO ij = iip1 + iip1, ip1jm, iip1
    180180        zqu(ij) = zqu(ij - iim)
    181181      enddo
    182       do ij = iip2 + 1, ip1jm
     182      DO ij = iip2 + 1, ip1jm
    183183        zqu(ij) = zqu(ij) + dxqu(ij - 1) / 12.
    184184      enddo
    185       do ij = iip1 + iip1, ip1jm, iip1
     185      DO ij = iip1 + iip1, ip1jm, iip1
    186186        zqu(ij - iim) = zqu(ij)
    187187      enddo
    … …  
    189189      !   calcul des valeurs max et min acceptees aux interfaces
    190190
    191       do ij = iip2, ip1jm - 1
     191      DO ij = iip2, ip1jm - 1
    192192        zqmax(ij) = max(q(ij + 1, l), q(ij, l))
    193193        zqmin(ij) = min(q(ij + 1, l), q(ij, l))
    194194      enddo
    195       do ij = iip1 + iip1, ip1jm, iip1
     195      DO ij = iip1 + iip1, ip1jm, iip1
    196196        zqmax(ij) = zqmax(ij - iim)
    197197        zqmin(ij) = zqmin(ij - iim)
    198198      enddo
    199       do ij = iip2 + 1, ip1jm
     199      DO ij = iip2 + 1, ip1jm
    200200        extremum(ij) = dxqu(ij) * dxqu(ij - 1)<=0.
    201201      enddo
    202       do ij = iip1 + iip1, ip1jm, iip1
     202      DO ij = iip1 + iip1, ip1jm, iip1
    203203        extremum(ij - iim) = extremum(ij)
    204204      enddo
    205       do ij = iip2, ip1jm
     205      DO ij = iip2, ip1jm
    206206        zqu(ij) = min(max(zqmin(ij), zqu(ij)), zqmax(ij))
    207207      enddo
    208       do ij = iip2 + 1, ip1jm
     208      DO ij = iip2 + 1, ip1jm
    209209        IF(extremum(ij)) THEN
    210210          qg(ij, l) = q(ij, l)
    … …  
    215215        endif
    216216      enddo
    217       do ij = iip1 + iip1, ip1jm, iip1
     217      DO ij = iip1 + iip1, ip1jm, iip1
    218218        qd(ij - iim, l) = qd(ij, l)
    219219        qg(ij - iim, l) = qg(ij, l)
    … …  
    222222      goto 8888
    223223
    224       do ij = iip2 + 1, ip1jm
     224      DO ij = iip2 + 1, ip1jm
    225225        IF(extremum(ij).and..not.extremum(ij - 1)) &
    226226                qd(ij - 1, l) = q(ij, l)
    227227      enddo
    228228
    229       do ij = iip1 + iip1, ip1jm, iip1
     229      DO ij = iip1 + iip1, ip1jm, iip1
    230230        qd(ij - iim, l) = qd(ij, l)
    231231      enddo
    232       do ij = iip2, ip1jm - 1
     232      DO ij = iip2, ip1jm - 1
    233233        IF (extremum(ij).and..not.extremum(ij + 1)) &
    234234                qg(ij + 1, l) = q(ij, l)
    235235      enddo
    236236
    237       do ij = iip1 + iip1, ip1jm, iip1
     237      DO ij = iip1 + iip1, ip1jm, iip1
    238238        qg(ij, l) = qg(ij - iim, l)
    239239      enddo
    … …  
    273273
    274274  IF (mode==0) THEN
    275     do l = 1, llm
    276       do ij = 1, ip1jmp1
     275    DO l = 1, llm
     276      DO ij = 1, ip1jmp1
    277277        qn(ij, l) = q(ij, l)
    278278        qs(ij, l) = q(ij, l)
    … …  
    283283    !   calcul des pentes en u:
    284284    !   -----------------------
    285     do l = 1, llm
    286       do ij = 1, ip1jm
     285    DO l = 1, llm
     286      DO ij = 1, ip1jm
    287287        dyqv(ij) = q(ij, l) - q(ij + iip1, l)
    288288      enddo
    289289
    290       do ij = iip2, ip1jm - iip1
     290      DO ij = iip2, ip1jm - iip1
    291291        zqv(ij, l) = 0.5 * (q(ij + iip1, l) + q(ij, l))
    292292        zqv(ij, l) = zqv(ij, l) + (dyqv(ij + iip1) - dyqv(ij - iip1)) / 12.
    293293      enddo
    294294
    295       do ij = iip2, ip1jm
     295      DO ij = iip2, ip1jm
    296296        extremum(ij) = dyqv(ij) * dyqv(ij - iip1)<=0.
    297297      enddo
    298298
    299299      ! Pas de pentes aux poles
    300       do ij = 1, iip1
     300      DO ij = 1, iip1
    301301        zqv(ij, l) = q(ij, l)
    302302        zqv(ip1jm - iip1 + ij, l) = q(ip1jm + ij, l)
    … …  
    306306
    307307      !   calcul des valeurs max et min acceptees aux interfaces
    308       do ij = 1, ip1jm
     308      DO ij = 1, ip1jm
    309309        zqmax(ij) = max(q(ij + iip1, l), q(ij, l))
    310310        zqmin(ij) = min(q(ij + iip1, l), q(ij, l))
    311311      enddo
    312312
    313       do ij = 1, ip1jm
     313      DO ij = 1, ip1jm
    314314        zqv(ij, l) = min(max(zqmin(ij), zqv(ij, l)), zqmax(ij))
    315315      enddo
    316316
    317       do ij = iip2, ip1jm
     317      DO ij = iip2, ip1jm
    318318        IF(extremum(ij)) THEN
    319319          qs(ij, l) = q(ij, l)
    … …  
    327327      enddo
    328328
    329       do ij = 1, iip1
     329      DO ij = 1, iip1
    330330        qs(ij, l) = q(ij, l)
    331331        qn(ij, l) = q(ij, l)
    … …  
    373373
    374374  IF (mode==0) THEN
    375     do l = 1, llm
    376       do ij = 1, ip1jmp1
     375    DO l = 1, llm
     376      DO ij = 1, ip1jmp1
    377377        qb(ij, l) = q(ij, l)
    378378        qh(ij, l) = q(ij, l)
    … …  
    380380    enddo
    381381  else
    382     do l = 2, llm
    383       do ij = 1, ip1jmp1
     382    DO l = 2, llm
     383      DO ij = 1, ip1jmp1
    384384        dzqw(ij, l) = q(ij, l - 1) - q(ij, l)
    385385        zqw(ij, l) = 0.5 * (q(ij, l - 1) + q(ij, l))
    386386      enddo
    387387    enddo
    388     do ij = 1, ip1jmp1
     388    DO ij = 1, ip1jmp1
    389389      dzqw(ij, 1) = 0.
    390390      dzqw(ij, llm + 1) = 0.
    391391    enddo
    392     do l = 2, llm
    393       do ij = 1, ip1jmp1
     392    DO l = 2, llm
     393      DO ij = 1, ip1jmp1
    394394        zqw(ij, l) = zqw(ij, l) + (dzqw(ij, l + 1) - dzqw(ij, l - 1)) / 12.
    395395      enddo
    396396    enddo
    397     do l = 2, llm - 1
    398       do ij = 1, ip1jmp1
     397    DO l = 2, llm - 1
     398      DO ij = 1, ip1jmp1
    399399        extremum(ij, l) = dzqw(ij, l) * dzqw(ij, l + 1)<=0.
    400400      enddo
    … …  
    402402
    403403    ! Pas de pentes en bas et en haut
    404     do ij = 1, ip1jmp1
     404    DO ij = 1, ip1jmp1
    405405      zqw(ij, 2) = q(ij, 1)
    406406      zqw(ij, llm) = q(ij, llm)
    … …  
    410410
    411411    !   calcul des valeurs max et min acceptees aux interfaces
    412     do l = 2, llm
    413       do ij = 1, ip1jmp1
     412    DO l = 2, llm
     413      DO ij = 1, ip1jmp1
    414414        zqmax(ij, l) = max(q(ij, l - 1), q(ij, l))
    415415        zqmin(ij, l) = min(q(ij, l - 1), q(ij, l))
    … …  
    417417    enddo
    418418
    419     do l = 2, llm
    420       do ij = 1, ip1jmp1
     419    DO l = 2, llm
     420      DO ij = 1, ip1jmp1
    421421        zqw(ij, l) = min(max(zqmin(ij, l), zqw(ij, l)), zqmax(ij, l))
    422422      enddo
    423423    enddo
    424424
    425     do l = 2, llm - 1
    426       do ij = 1, ip1jmp1
     425    DO l = 2, llm - 1
     426      DO ij = 1, ip1jmp1
    427427        IF(extremum(ij, l)) THEN
    428428          qh(ij, l) = q(ij, l)
    … …  
    443443    ! enddo
    444444
    445     do ij = 1, ip1jmp1
     445    DO ij = 1, ip1jmp1
    446446      qb(ij, 1) = q(ij, 1)
    447447      qh(ij, 1) = q(ij, 1)
    … …  
    499499  data prec/1.e-15/
    500500
    501   do l = 1, llm
    502     do ij = iip2, ip1jm
     501  DO l = 1, llm
     502    DO ij = iip2, ip1jm
    503503      zdq = qd(ij, l) - qg(ij, l)
    504504      ! if((qd(ij,l)-q(ij,l))*(q(ij,l)-qg(ij,l)).lt.0.) THEN
    … …  
    529529  !   calcul de la pente maximum dans la maille en valeur absolue
    530530
    531   do l = 1, llm
    532     do ij = iip2, ip1jm - 1
     531  DO l = 1, llm
     532    DO ij = iip2, ip1jm - 1
    533533      IF (u_m(ij, l)>=0.) THEN
    534534        zsigp = zsigd(ij, l)
    … …  
    573573  enddo
    574574
    575   do l = 1, llm
    576     do ij = iip1 + iip1, ip1jm, iip1
     575  DO l = 1, llm
     576    DO ij = iip1 + iip1, ip1jm, iip1
    577577      u_mq(ij, l) = u_mq(ij - iim, l)
    578578      ladvplus(ij, l) = ladvplus(ij - iim, l)
    … …  
    585585  !   tris des regions a traiter
    586586  n0 = 0
    587   do l = 1, llm
     587  DO l = 1, llm
    588588    nl(l) = 0
    589     do ij = iip2, ip1jm
     589    DO ij = iip2, ip1jm
    590590      IF(ladvplus(ij, l)) THEN
    591591        nl(l) = nl(l) + 1
    … …  
    601601            , 'contenu de la maille : ', n0
    602602
    603     do l = 1, llm
     603    DO l = 1, llm
    604604      IF(nl(l)>0) THEN
    605605        iju = 0
    606606        !   indicage des mailles concernees par le traitement special
    607         do ij = iip2, ip1jm
     607        DO ij = iip2, ip1jm
    608608          IF(ladvplus(ij, l).AND.mod(ij, iip1)/=0) THEN
    609609            iju = iju + 1
    … …  
    615615
    616616        !  traitement des mailles
    617         do iju = 1, niju
     617        DO iju = 1, niju
    618618          ij = indu(iju)
    619619          j = (ij - 1) / iip1 + 1
    … …  
    624624            i = ijq - (j - 1) * iip1
    625625            !   accumulation pour les mailles completements advectees
    626             do while(zu_m>masse(ijq, l))
     626            DO while(zu_m>masse(ijq, l))
    627627              u_mq(ij, l) = u_mq(ij, l) + q(ijq, l) * masse(ijq, l)
    628628              zu_m = zu_m - masse(ijq, l)
    … …  
    654654            i = ijq - (j - 1) * iip1
    655655            !   accumulation pour les mailles completements advectees
    656             do while(-zu_m>masse(ijq, l))
     656            DO while(-zu_m>masse(ijq, l))
    657657              u_mq(ij, l) = u_mq(ij, l) - q(ijq, l) * masse(ijq, l)
    658658              zu_m = zu_m + masse(ijq, l)
    … …  
    689689
    690690  !   bouclage en latitude
    691   do l = 1, llm
    692     do ij = iip1 + iip1, ip1jm, iip1
     691  DO l = 1, llm
     692    DO ij = iip1 + iip1, ip1jm, iip1
    693693      u_mq(ij, l) = u_mq(ij - iim, l)
    694694    enddo
    … …  
    699699  !=================================================================
    700700
    701   do l = 1, llm
    702     do ij = iip2 + 1, ip1jm
     701  DO l = 1, llm
     702    DO ij = iip2 + 1, ip1jm
    703703      new_m = masse(ij, l) + u_m(ij - 1, l) - u_m(ij, l)
    704704      q(ij, l) = (q(ij, l) * masse(ij, l) + &
    … …  
    708708    enddo
    709709    !   Modif Fred 22 03 96 correction d'un bug (les scopy ci-dessous)
    710     do ij = iip1 + iip1, ip1jm, iip1
     710    DO ij = iip1 + iip1, ip1jm, iip1
    711711      q(ij - iim, l) = q(ij, l)
    712712      masse(ij - iim, l) = masse(ij, l)
    … …  
    757757
    758758  data prec/1.e-15/
    759   do l = 1, llm
    760     do ij = 1, ip1jmp1
     759  DO l = 1, llm
     760    DO ij = 1, ip1jmp1
    761761      zdq = qn(ij, l) - qs(ij, l)
    762762      ! if((qn(ij,l)-q(ij,l))*(q(ij,l)-qs(ij,l)).lt.0.) THEN
    … …  
    783783    !   calcul de la pente maximum dans la maille en valeur absolue
    784784
    785     do ij = 1, ip1jm
     785    DO ij = 1, ip1jm
    786786      IF (v_m(ij, l)>=0.) THEN
    787787        zsigp = zsign(ij + iip1)
    … …  
    811811  enddo
    812812
    813   do l = 1, llm
    814     do ij = iip2, ip1jm
     813  DO l = 1, llm
     814    DO ij = iip2, ip1jm
    815815      new_m = masse(ij, l) &
    816816              + v_m(ij, l) - v_m(ij - iip1, l)
    … …  
    825825    new_m = massen + convmpn
    826826    q(1, l) = (q(1, l) * massen + convpn) / new_m
    827     do ij = 1, iip1
     827    DO ij = 1, iip1
    828828      q(ij, l) = q(1, l)
    829829      masse(ij, l) = new_m * aire(ij) / apoln
    … …  
    835835    new_m = masses + convmps
    836836    q(ip1jm + 1, l) = (q(ip1jm + 1, l) * masses + convps) / new_m
    837     do ij = ip1jm + 1, ip1jmp1
     837    DO ij = ip1jm + 1, ip1jmp1
    838838      q(ij, l) = q(ip1jm + 1, l)
    839839      masse(ij, l) = new_m * aire(ij) / apols
    … …  
    885885  data prec/1.e-13/
    886886
    887   do l = 1, llm
    888     do ij = 1, ip1jmp1
     887  DO l = 1, llm
     888    DO ij = 1, ip1jmp1
    889889      zdq = qb(ij, l) - qh(ij, l)
    890890      ! if((qh(ij,l)-q(ij,l))*(q(ij,l)-qb(ij,l)).lt.0.) THEN
    … …  
    908908  ! PRINT*,'ok1'
    909909  !   calcul de la pente maximum dans la maille en valeur absolue
    910   do l = 2, llm
    911     do ij = 1, ip1jmp1
     910  DO l = 2, llm
     911    DO ij = 1, ip1jmp1
    912912      IF (w_m(ij, l)>=0.) THEN
    913913        zsigp = zsigb(ij, l)
    … …  
    937937  enddo
    938938
    939   do ij = 1, ip1jmp1
     939  DO ij = 1, ip1jmp1
    940940    w_mq(ij, llm + 1) = 0.
    941941    w_mq(ij, 1) = 0.
    942942  enddo
    943943
    944   do l = 1, llm
    945     do ij = 1, ip1jmp1
     944  DO l = 1, llm
     945    DO ij = 1, ip1jmp1
    946946      new_m = masse(ij, l) + w_m(ij, l + 1) - w_m(ij, l)
    947947      q(ij, l) = (q(ij, l) * masse(ij, l) + w_mq(ij, l + 1) - w_mq(ij, l)) &

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/advy.f90

    r5136 r5158  
    113113      enddo
    114114    enddo
    115     do i = 1, iip1
     115    DO i = 1, iip1
    116116      vgri(i, 0, l) = 0.
    117117      vgri(i, jjp1, l) = 0.

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/advzp.f90

    r5136 r5158  
    141141    END DO
    142142  END DO
    143   do j = 1, jjp1
    144     do i = 1, iip1
     143  DO j = 1, jjp1
     144    DO i = 1, iip1
    145145      wgri(i, j, 0) = 0.
    146146    enddo

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/diagedyn.f90

    r5136 r5158  
    244244  airetot=0.
    245245  !
    246   do i=1,imjmp1
     246  DO i=1,imjmp1
    247247    qw_tot = qw_tot + zqw_col(i)
    248248    ql_tot = ql_tot + zql_col(i)

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/disvert.F90

    r5134 r5158  
    8989     zkm1=0.
    9090     sig(1)=1.
    91      do l=1, llm
     91     DO l=1, llm
    9292        sig(l+1)=(cosh(l/k0))**(-alpha*k0/scaleheight) &
    9393             *exp(-alpha/scaleheight*tanh((llm-k1)/k0) &
    … …  
    315315          position="rewind")
    316316     read(unit, fmt=*) ! skip title line
    317      do l = 1, llm + 1
     317     DO l = 1, llm + 1
    318318        read(unit, fmt=*) ap(l), bp(l)
    319319     END DO

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/disvert_noterre.f90

    r5134 r5158  
    9191     esig=1.
    9292
    93      do l=1,20
     93     DO l=1,20
    9494        esig=-log((1./sig1-1.)*exp(-dz0)/esig)/(llm-1.)
    9595     enddo
    … …  
    129129
    130130     READ(99,*) scaleheight
    131      do l=1,llm
     131     DO l=1,llm
    132132        read(99,*) zsig(l)
    133133     END DO
    … …  
    135135
    136136     sig(1) =1
    137      do l=2,llm
     137     DO l=2,llm
    138138       sig(l) = 0.5 * ( exp(-zsig(l)/scaleheight) + &
    139139             exp(-zsig(l-1)/scaleheight) )

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/ener_mod.F90

    r5134 r5158  
    99INCLUDE "paramet.h"
    1010
    11       REAL ang0,etot0,ptot0,ztot0,stot0,                        &
    12                 ang,etot,ptot,ztot,stot,rmsdpdt,rmsv,gtot(llmm1)
     11      REAL ang0,etot0,ptot0,ztot0,stot0,            &
     12        ang,etot,ptot,ztot,stot,rmsdpdt,rmsv,gtot(llmm1)
    1313
    1414

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/fxhyp_m.F90

    r5134 r5158  
    189189             is2 = 1
    190190
    191              do while (rlonm025(is2) < - pi .AND. is2 < iim)
     191             DO while (rlonm025(is2) < - pi .AND. is2 < iim)
    192192                is2 = is2 + 1
    193193             END DO
    … …  
    200200             is2 = iim
    201201
    202              do while (rlonm025(is2) > pi .AND. is2 > 1)
     202             DO while (rlonm025(is2) > pi .AND. is2 > 1)
    203203                is2 = is2 - 1
    204204             END DO

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/gr_ecrit_fi.f90

    r5134 r5158  
    1818
    1919    jjm = jjmp1 - 1
    20     do n = 1, nfield
     20    DO n = 1, nfield
    2121        fi(1,n) = ecrit(1,1,n)
    2222        fi(nlon,n) = ecrit(1,jjm+1,n)

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/gr_int_dyn.f90

    r5117 r5158  
    2626  polenord = 0.
    2727  polesud = 0.
    28   do i = 1, iim
     28  DO i = 1, iim
    2929    polenord = polenord + champin (i, 1)
    3030    polesud = polesud + champin (i, jp1)
    … …  
    3232  polenord = polenord / iim
    3333  polesud = polesud / iim
    34   do j = 1, jp1
    35     do i = 1, iim
     34  DO j = 1, jp1
     35    DO i = 1, iim
    3636      IF (j == 1) THEN
    3737        champdyn(i, j) = polenord

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/grilles_gcm_netcdf_sub.F90

    r5136 r5158  
    1 
    21! $Id: $
    32
    … …  
    109! The SUBROUTINE is called in dynphy_lonlat/phylmd/ce0l.F90.
    1110
    12 SUBROUTINE grilles_gcm_netcdf_sub(masque,phis)
     11SUBROUTINE grilles_gcm_netcdf_sub(masque, phis)
    1312
    1413  USE comconst_mod, ONLY: cpp, kappa, g, omeg, daysec, rad, pi
    1514  USE comvert_mod, ONLY: presnivs, preff, pa
    1615  USE netcdf, ONLY: nf90_def_var, nf90_int, nf90_float, nf90_put_var, nf90_enddef, &
    17       nf90_put_att,nf90_def_dim,nf90_64bit_offset,nf90_clobber,nf90_create
     16          nf90_put_att, nf90_def_dim, nf90_64bit_offset, nf90_clobber, nf90_create
    1817  USE lmdz_comgeom
    19  
     18
    2019  IMPLICIT NONE
    2120
    … …  
    2322  INCLUDE "paramet.h"
    2423
    25 !========================
    26   REAL,DIMENSION(iip1,jjp1),INTENT(IN) :: masque ! masque terre/mer
    27   REAL,DIMENSION(iip1,jjp1),INTENT(IN) :: phis   ! geopotentiel au sol
    28 
    29   INTEGER status,i,j
    30  
     24  !========================
     25  REAL, DIMENSION(iip1, jjp1), INTENT(IN) :: masque ! masque terre/mer
     26  REAL, DIMENSION(iip1, jjp1), INTENT(IN) :: phis   ! geopotentiel au sol
     27
     28  INTEGER status, i, j
     29
    3130  ! Attributs netcdf output
    32   INTEGER ncid_out,rcode_out
    33  
    34   INTEGER out_lonuid,out_lonvid,out_latuid,out_latvid
    35   INTEGER out_uid,out_vid,out_tempid
    36   INTEGER out_lonudim,out_lonvdim
    37   INTEGER out_latudim,out_latvdim,out_dim(2)
     31  INTEGER ncid_out, rcode_out
     32
     33  INTEGER out_lonuid, out_lonvid, out_latuid, out_latvid
     34  INTEGER out_uid, out_vid, out_tempid
     35  INTEGER out_lonudim, out_lonvdim
     36  INTEGER out_latudim, out_latvdim, out_dim(2)
    3837  INTEGER out_levdim
    3938
    4039  INTEGER :: presnivs_id
    41   INTEGER :: mask_id,area_id,phis_id
    42 
    43   INTEGER start(2),COUNT(2)
     40  INTEGER :: mask_id, area_id, phis_id
     41
     42  INTEGER start(2), COUNT(2)
    4443
    4544  ! Variables
    46   REAL rlatudeg(jjp1),rlatvdeg(jjm),rlev(llm)
    47   REAL rlonudeg(iip1),rlonvdeg(iip1)
    48   REAL uwnd(iip1,jjp1),vwnd(iip1,jjm),temp(iip1,jjp1)
    49 
    50   INTEGER masque_int(iip1,jjp1)
    51   REAL :: phis_loc(iip1,jjp1)
    52  
     45  REAL rlatudeg(jjp1), rlatvdeg(jjm), rlev(llm)
     46  REAL rlonudeg(iip1), rlonvdeg(iip1)
     47  REAL uwnd(iip1, jjp1), vwnd(iip1, jjm), temp(iip1, jjp1)
     48
     49  INTEGER masque_int(iip1, jjp1)
     50  REAL :: phis_loc(iip1, jjp1)
     51
    5352  !========================
    5453  ! CALCULATION of latu, latv, lonu, lonv in deg.
    … …  
    6261
    6362  preff = 101325.
    64   pa= 50000.
    65 
    66   CALL conf_gcm( 99, .TRUE. )
     63  pa = 50000.
     64
     65  CALL conf_gcm(99, .TRUE.)
    6766  CALL iniconst
    6867  CALL inigeom
    6968
    70   DO j=1,jjp1
    71      rlatudeg(j)=rlatu(j)*180./pi
    72   ENDDO
    73  
    74   DO j=1,jjm
    75      rlatvdeg(j)=rlatv(j)*180./pi
    76   ENDDO
    77 
    78   DO i=1,iip1
    79      rlonudeg(i)=rlonu(i)*180./pi + 360.
    80      rlonvdeg(i)=rlonv(i)*180./pi + 360.
    81   ENDDO
    82  
     69  DO j = 1, jjp1
     70    rlatudeg(j) = rlatu(j) * 180. / pi
     71  ENDDO
     72
     73  DO j = 1, jjm
     74    rlatvdeg(j) = rlatv(j) * 180. / pi
     75  ENDDO
     76
     77  DO i = 1, iip1
     78    rlonudeg(i) = rlonu(i) * 180. / pi + 360.
     79    rlonvdeg(i) = rlonv(i) * 180. / pi + 360.
     80  ENDDO
     81
    8382  ! CALCULATION of "false" variables on u, v, s grids
    8483  ! ---------------------------------------------------
    85    DO i=1,iip1
    86      DO j=1,jjp1
    87         uwnd(i,j)=MOD(i,2)+MOD(j,2)
    88         temp(i,j)=MOD(i,2)+MOD(j,2)
    89      ENDDO
    90      DO j=1,jjm
    91         vwnd(i,j)=MOD(i,2)+MOD(j,2)
    92      END DO
    93   ENDDO 
     84  DO i = 1, iip1
     85    DO j = 1, jjp1
     86      uwnd(i, j) = MOD(i, 2) + MOD(j, 2)
     87      temp(i, j) = MOD(i, 2) + MOD(j, 2)
     88    ENDDO
     89    DO j = 1, jjm
     90      vwnd(i, j) = MOD(i, 2) + MOD(j, 2)
     91    END DO
     92  ENDDO
    9493
    9594  ! CALCULATION of local vars for presnivs, mask, sfc. geopot. height
    9695  ! ---------------------------------------------------
    9796  rlev(:) = presnivs(:)
    98   phis_loc(:,:) = phis(:,:)/g
    99   masque_int(:,:) = nINT(masque(:,:))
     97  phis_loc(:, :) = phis(:, :) / g
     98  masque_int(:, :) = nINT(masque(:, :))
    10099
    101100
    102101  ! OPEN output netcdf file
    103102  !-------------------------
    104   status=nf90_create('grilles_gcm.nc',IOR(nf90_clobber,nf90_64bit_offset),ncid_out)
    105   CALL handle_err(status)
    106  
     103  status = nf90_create('grilles_gcm.nc', IOR(nf90_clobber, nf90_64bit_offset), ncid_out)
     104  CALL handle_err(status)
     105
    107106  ! DEFINE output dimensions
    108107  !-------------------------
    109   status=nf90_def_dim(ncid_out,'lonu',iim+1,out_lonudim)
    110   CALL handle_err(status)
    111   status=nf90_def_dim(ncid_out,'lonv',iim+1,out_lonvdim)
    112   CALL handle_err(status)
    113   status=nf90_def_dim(ncid_out,'latu',jjm+1,out_latudim)
    114   CALL handle_err(status)
    115   status=nf90_def_dim(ncid_out,'latv',jjm,out_latvdim)
    116   CALL handle_err(status)
    117 
    118   status=nf90_def_dim(ncid_out,'lev',llm,out_levdim)
    119   CALL handle_err(status)
    120  
     108  status = nf90_def_dim(ncid_out, 'lonu', iim + 1, out_lonudim)
     109  CALL handle_err(status)
     110  status = nf90_def_dim(ncid_out, 'lonv', iim + 1, out_lonvdim)
     111  CALL handle_err(status)
     112  status = nf90_def_dim(ncid_out, 'latu', jjm + 1, out_latudim)
     113  CALL handle_err(status)
     114  status = nf90_def_dim(ncid_out, 'latv', jjm, out_latvdim)
     115  CALL handle_err(status)
     116
     117  status = nf90_def_dim(ncid_out, 'lev', llm, out_levdim)
     118  CALL handle_err(status)
     119
    121120  ! DEFINE output variables
    122121  !-------------------------
    123122  !   Longitudes on "u" dynamical grid
    124   status=nf90_def_var(ncid_out,'lonu',nf90_float,out_lonudim, out_lonuid)
    125   CALL handle_err(status)
    126   status=nf90_put_att(ncid_out,out_lonuid,'units','degrees_east')
    127   status=nf90_put_att(ncid_out,out_lonuid,'long_name','Longitude on u grid')
     123  status = nf90_def_var(ncid_out, 'lonu', nf90_float, out_lonudim, out_lonuid)
     124  CALL handle_err(status)
     125  status = nf90_put_att(ncid_out, out_lonuid, 'units', 'degrees_east')
     126  status = nf90_put_att(ncid_out, out_lonuid, 'long_name', 'Longitude on u grid')
    128127  !   Longitudes on "v" dynamical grid
    129   status=nf90_def_var(ncid_out,'lonv',nf90_float,out_lonvdim, out_lonvid)
    130   CALL handle_err(status)
    131   status=nf90_put_att(ncid_out,out_lonvid,'units','degrees_east')
    132   status=nf90_put_att(ncid_out,out_lonvid,'long_name','Longitude on v grid')
     128  status = nf90_def_var(ncid_out, 'lonv', nf90_float, out_lonvdim, out_lonvid)
     129  CALL handle_err(status)
     130  status = nf90_put_att(ncid_out, out_lonvid, 'units', 'degrees_east')
     131  status = nf90_put_att(ncid_out, out_lonvid, 'long_name', 'Longitude on v grid')
    133132  !   Latitudes on "u" dynamical grid
    134   status=nf90_def_var(ncid_out,'latu',nf90_float,out_latudim, out_latuid)
    135   CALL handle_err(status)
    136   status=nf90_put_att(ncid_out,out_latuid,'units','degrees_north')
    137   status=nf90_put_att(ncid_out,out_latuid,'long_name','Latitude on u grid')
     133  status = nf90_def_var(ncid_out, 'latu', nf90_float, out_latudim, out_latuid)
     134  CALL handle_err(status)
     135  status = nf90_put_att(ncid_out, out_latuid, 'units', 'degrees_north')
     136  status = nf90_put_att(ncid_out, out_latuid, 'long_name', 'Latitude on u grid')
    138137  !  Latitudes on "v" dynamical grid
    139   status=nf90_def_var(ncid_out,'latv',nf90_float,out_latvdim, out_latvid)
    140   CALL handle_err(status)
    141   status=nf90_put_att(ncid_out,out_latvid,'units','degrees_north')
    142   status=nf90_put_att(ncid_out,out_latvid,'long_name','Latitude on v grid')
     138  status = nf90_def_var(ncid_out, 'latv', nf90_float, out_latvdim, out_latvid)
     139  CALL handle_err(status)
     140  status = nf90_put_att(ncid_out, out_latvid, 'units', 'degrees_north')
     141  status = nf90_put_att(ncid_out, out_latvid, 'long_name', 'Latitude on v grid')
    143142  !  "u" lat/lon dynamical grid
    144   out_dim(1)=out_lonudim
    145   out_dim(2)=out_latudim
    146   status=nf90_def_var(ncid_out,'grille_u',nf90_float,out_dim, out_uid)
    147   CALL handle_err(status)
    148   status=nf90_put_att(ncid_out,out_uid,'units','m/s')
    149   status=nf90_put_att(ncid_out,out_uid,'long_name','u-wind dynamical grid')
     143  out_dim(1) = out_lonudim
     144  out_dim(2) = out_latudim
     145  status = nf90_def_var(ncid_out, 'grille_u', nf90_float, out_dim, out_uid)
     146  CALL handle_err(status)
     147  status = nf90_put_att(ncid_out, out_uid, 'units', 'm/s')
     148  status = nf90_put_att(ncid_out, out_uid, 'long_name', 'u-wind dynamical grid')
    150149  !  "v" lat/lon dynamical grid
    151   out_dim(1)=out_lonvdim
    152   out_dim(2)=out_latvdim
    153   status=nf90_def_var(ncid_out,'grille_v',nf90_float,out_dim, out_vid)
    154   CALL handle_err(status)
    155   status=nf90_put_att(ncid_out,out_vid,'units','m/s')
    156   status=nf90_put_att(ncid_out,out_vid,'long_name','v-wind dynamical grid')
     150  out_dim(1) = out_lonvdim
     151  out_dim(2) = out_latvdim
     152  status = nf90_def_var(ncid_out, 'grille_v', nf90_float, out_dim, out_vid)
     153  CALL handle_err(status)
     154  status = nf90_put_att(ncid_out, out_vid, 'units', 'm/s')
     155  status = nf90_put_att(ncid_out, out_vid, 'long_name', 'v-wind dynamical grid')
    157156  !  "s" (scalar) lat/lon dynamical grid
    158   out_dim(1)=out_lonvdim
    159   out_dim(2)=out_latudim
    160   status=nf90_def_var(ncid_out,'grille_s',nf90_float,out_dim, out_tempid)
    161   CALL handle_err(status)
    162   status=nf90_put_att(ncid_out,out_tempid,'units','Kelvin')
    163   status=nf90_put_att(ncid_out,out_tempid,'long_name','scalar dynamical grid')
     157  out_dim(1) = out_lonvdim
     158  out_dim(2) = out_latudim
     159  status = nf90_def_var(ncid_out, 'grille_s', nf90_float, out_dim, out_tempid)
     160  CALL handle_err(status)
     161  status = nf90_put_att(ncid_out, out_tempid, 'units', 'Kelvin')
     162  status = nf90_put_att(ncid_out, out_tempid, 'long_name', 'scalar dynamical grid')
    164163
    165164  ! for INCA :
    166165  ! vertical levels "presnivs"
    167   status=nf90_def_var(ncid_out,'presnivs',nf90_float,out_levdim, presnivs_id)
    168   CALL handle_err(status)
    169   status=nf90_put_att(ncid_out,presnivs_id,'units','Pa')
    170   status=nf90_put_att(ncid_out,presnivs_id,'long_name','Vertical levels')
     166  status = nf90_def_var(ncid_out, 'presnivs', nf90_float, out_levdim, presnivs_id)
     167  CALL handle_err(status)
     168  status = nf90_put_att(ncid_out, presnivs_id, 'units', 'Pa')
     169  status = nf90_put_att(ncid_out, presnivs_id, 'long_name', 'Vertical levels')
    171170  ! surface geopotential height: named "phis" as the sfc geopotential, is actually phis/g
    172   out_dim(1)=out_lonvdim
    173   out_dim(2)=out_latudim
    174   status = nf90_def_var(ncid_out,'phis',nf90_float,out_dim,phis_id)
    175   CALL handle_err(status)
    176   status=nf90_put_att(ncid_out,phis_id,'units','m')
    177   status=nf90_put_att(ncid_out,phis_id,'long_name','surface geopotential height')
     171  out_dim(1) = out_lonvdim
     172  out_dim(2) = out_latudim
     173  status = nf90_def_var(ncid_out, 'phis', nf90_float, out_dim, phis_id)
     174  CALL handle_err(status)
     175  status = nf90_put_att(ncid_out, phis_id, 'units', 'm')
     176  status = nf90_put_att(ncid_out, phis_id, 'long_name', 'surface geopotential height')
    178177  ! gridcell area
    179   status = nf90_def_var(ncid_out,'aire',nf90_float,out_dim,area_id)
    180   CALL handle_err(status)
    181   status=nf90_put_att(ncid_out,area_id,'units','m2')
    182   status=nf90_put_att(ncid_out,area_id,'long_name','gridcell area')
     178  status = nf90_def_var(ncid_out, 'aire', nf90_float, out_dim, area_id)
     179  CALL handle_err(status)
     180  status = nf90_put_att(ncid_out, area_id, 'units', 'm2')
     181  status = nf90_put_att(ncid_out, area_id, 'long_name', 'gridcell area')
    183182  ! land-sea mask (nearest integer approx)
    184   status = nf90_def_var(ncid_out,'mask',nf90_int,out_dim,mask_id)
    185   CALL handle_err(status)
    186   status=nf90_put_att(ncid_out,mask_id,'long_name','land-sea mask (nINT approx)')
    187  
     183  status = nf90_def_var(ncid_out, 'mask', nf90_int, out_dim, mask_id)
     184  CALL handle_err(status)
     185  status = nf90_put_att(ncid_out, mask_id, 'long_name', 'land-sea mask (nINT approx)')
     186
    188187  ! END the 'define' mode in netCDF file
    189   status=nf90_enddef(ncid_out)
    190   CALL handle_err(status)
    191  
     188  status = nf90_enddef(ncid_out)
     189  CALL handle_err(status)
     190
    192191  ! WRITE the variables
    193192  !-------------------------
    194193  ! 1D : lonu, lonv,latu,latv ; INCA : presnivs
    195   status=nf90_put_var(ncid_out,out_lonuid,rlonudeg,[1],[iip1])
    196   CALL handle_err(status)
    197   status=nf90_put_var(ncid_out,out_lonvid,rlonvdeg,[1],[iip1])
    198   CALL handle_err(status)
    199   status=nf90_put_var(ncid_out,out_latuid,rlatudeg,[1],[jjp1])
    200   CALL handle_err(status)
    201   status=nf90_put_var(ncid_out,out_latvid,rlatvdeg,[1],[jjm])
    202   CALL handle_err(status)
    203   status=nf90_put_var(ncid_out,presnivs_id,rlev,[1],[llm])
     194  status = nf90_put_var(ncid_out, out_lonuid, rlonudeg, [1], [iip1])
     195  CALL handle_err(status)
     196  status = nf90_put_var(ncid_out, out_lonvid, rlonvdeg, [1], [iip1])
     197  CALL handle_err(status)
     198  status = nf90_put_var(ncid_out, out_latuid, rlatudeg, [1], [jjp1])
     199  CALL handle_err(status)
     200  status = nf90_put_var(ncid_out, out_latvid, rlatvdeg, [1], [jjm])
     201  CALL handle_err(status)
     202  status = nf90_put_var(ncid_out, presnivs_id, rlev, [1], [llm])
    204203  CALL handle_err(status)
    205204
    206205  ! 2D : grille_u,grille_v,grille_s ; INCA: phis,aire,mask
    207   start(:)=1
    208   COUNT(1)=iip1
    209  
    210   COUNT(2)=jjp1  ! for "u" and "s" grids
    211   status=nf90_put_var(ncid_out,out_uid,uwnd,start, count)
    212   CALL handle_err(status)
    213   COUNT(2)=jjm  ! for "v" grid
    214   status=nf90_put_var(ncid_out,out_vid,vwnd,start, count)
    215   CALL handle_err(status) 
    216   COUNT(2)=jjp1  ! as "s" grid, for all the following vars
    217   status=nf90_put_var(ncid_out,out_tempid,temp,start, count)
    218   CALL handle_err(status)
    219   status = nf90_put_var(ncid_out, phis_id, phis_loc,start,count)
    220   CALL handle_err(status) 
    221   status = nf90_put_var(ncid_out, area_id, aire,start,count)
    222   CALL handle_err(status) 
    223   status = nf90_put_var(ncid_out, mask_id,masque_int,start,count)
    224   CALL handle_err(status)
    225  
     206  start(:) = 1
     207  COUNT(1) = iip1
     208
     209  COUNT(2) = jjp1  ! for "u" and "s" grids
     210  status = nf90_put_var(ncid_out, out_uid, uwnd, start, count)
     211  CALL handle_err(status)
     212  COUNT(2) = jjm  ! for "v" grid
     213  status = nf90_put_var(ncid_out, out_vid, vwnd, start, count)
     214  CALL handle_err(status)
     215  COUNT(2) = jjp1  ! as "s" grid, for all the following vars
     216  status = nf90_put_var(ncid_out, out_tempid, temp, start, count)
     217  CALL handle_err(status)
     218  status = nf90_put_var(ncid_out, phis_id, phis_loc, start, count)
     219  CALL handle_err(status)
     220  status = nf90_put_var(ncid_out, area_id, aire, start, count)
     221  CALL handle_err(status)
     222  status = nf90_put_var(ncid_out, mask_id, masque_int, start, count)
     223  CALL handle_err(status)
     224
    226225  ! CLOSE netcdf file
    227   CALL ncclos(ncid_out,rcode_out)
    228   WRITE(*,*) "END grilles_gcm_netcdf_sub OK"
     226  CALL ncclos(ncid_out, rcode_out)
     227  WRITE(*, *) "END grilles_gcm_netcdf_sub OK"
    229228
    230229END SUBROUTINE grilles_gcm_netcdf_sub
    … …  
    232231
    233232SUBROUTINE handle_err(status)
    234   USE netcdf, ONLY: nf90_strerror
    235 
     233  USE netcdf, ONLY: nf90_strerror, nf90_noerr
    236234
    237235  INTEGER status
    238236  IF (status/=nf90_noerr) THEN
    239      PRINT *,nf90_strerror(status)
    240      CALL abort_gcm('grilles_gcm_netcdf','netcdf error',1)
     237    PRINT *, nf90_strerror(status)
     238    CALL abort_gcm('grilles_gcm_netcdf', 'netcdf error', 1)
    241239  ENDIF
    242240END SUBROUTINE handle_err

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/inidissip.F90

    r5134 r5158  
    173173
    174174  IF (vert_prof_dissip == 1) THEN
    175     do l = 1, llm
     175    DO l = 1, llm
    176176      pseudoz = 8. * log(preff / presnivs(l))
    177177      zvert(l) = 1 + &

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/inigrads.f90

    r5137 r5158  
    4646  ifd(if) = im
    4747  imd(if) = im
    48   do i = 1, im
     48  DO i = 1, im
    4949    xd(i, if) = x(i) * fx
    5050    IF(xd(i, if)<xmin) iid(if) = i + 1
    … …  
    5656  jfd(if) = jm
    5757  jmd(if) = jm
    58   do j = 1, jm
     58  DO j = 1, jm
    5959    yd(j, if) = y(j) * fy
    6060    IF(yd(j, if)>ymax) jid(if) = j + 1
    … …  
    7878
    7979  lmd(if) = lm
    80   do l = 1, lm
     80  DO l = 1, lm
    8181    zd(l, if) = z(l) * fz
    8282  enddo

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/initdynav.F90

    r5136 r5158  
    6969  tau0 = itau_dyn
    7070
    71   do jj = 1, jjp1
    72     do ii = 1, iip1
     71  DO jj = 1, jjp1
     72    DO ii = 1, iip1
    7373      rlong(ii, jj) = rlonv(ii) * 180. / pi
    7474      rlat(ii, jj) = rlatu(jj) * 180. / pi
    … …  
    8787  ! de point differents dans  un meme fichier)
    8888  ! Grille V
    89   do jj = 1, jjm
    90     do ii = 1, iip1
     89  DO jj = 1, jjm
     90    DO ii = 1, iip1
    9191      rlong(ii, jj) = rlonv(ii) * 180. / pi
    9292      rlat(ii, jj) = rlatv(jj) * 180. / pi
    … …  
    9898          tau0, zjulian, tstep, vhoriid, histvaveid)
    9999  ! Grille U
    100   do jj = 1, jjp1
    101     do ii = 1, iip1
     100  DO jj = 1, jjp1
     101    DO ii = 1, iip1
    102102      rlong(ii, jj) = rlonu(ii) * 180. / pi
    103103      rlat(ii, jj) = rlatu(jj) * 180. / pi

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/initfluxsto.f90

    r5136 r5158  
    8181  tau0 = itau_dyn
    8282
    83   do jj = 1, jjp1
    84     do ii = 1, iip1
     83  DO jj = 1, jjp1
     84    DO ii = 1, iip1
    8585      rlong(ii, jj) = rlonu(ii) * 180. / pi
    8686      rlat(ii, jj) = rlatu(jj) * 180. / pi
    … …  
    9696  !  un meme fichier)
    9797
    98   do jj = 1, jjm
    99     do ii = 1, iip1
     98  DO jj = 1, jjm
     99    DO ii = 1, iip1
    100100      rlong(ii, jj) = rlonv(ii) * 180. / pi
    101101      rlat(ii, jj) = rlatv(jj) * 180. / pi
    … …  
    115115  !  Appel a histhori pour rajouter les autres grilles horizontales
    116116  !
    117   do jj = 1, jjp1
    118     do ii = 1, iip1
     117  DO jj = 1, jjp1
     118    DO ii = 1, iip1
    119119      rlong(ii, jj) = rlonv(ii) * 180. / pi
    120120      rlat(ii, jj) = rlatu(jj) * 180. / pi

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/inithist.F90

    r5136 r5158  
    7676  ! -------------------------------------------------------------
    7777  !Grille U
    78   do jj = 1, jjp1
    79     do ii = 1, iip1
     78  DO jj = 1, jjp1
     79    DO ii = 1, iip1
    8080      rlong(ii, jj) = rlonu(ii) * 180. / pi
    8181      rlat(ii, jj) = rlatu(jj) * 180. / pi
    … …  
    8888
    8989  ! Grille V
    90   do jj = 1, jjm
    91     do ii = 1, iip1
     90  DO jj = 1, jjm
     91    DO ii = 1, iip1
    9292      rlong(ii, jj) = rlonv(ii) * 180. / pi
    9393      rlat(ii, jj) = rlatv(jj) * 180. / pi
    … …  
    100100
    101101  !Grille Scalaire
    102   do jj = 1, jjp1
    103     do ii = 1, iip1
     102  DO jj = 1, jjp1
     103    DO ii = 1, iip1
    104104      rlong(ii, jj) = rlonv(ii) * 180. / pi
    105105      rlat(ii, jj) = rlatu(jj) * 180. / pi

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/inter_barxy_m.F90

    r5136 r5158  
    261261    idat = 1
    262262
    263     do while (imod <= imodmax)
    264       do while (xxim(imod)>xxid(idat))
     263    DO while (imod <= imodmax)
     264      DO while (xxim(imod)>xxid(idat))
    265265        dx = xxid(idat) - x0
    266266        dxm = dxm + dx
    … …  
    330330    jdat = 1
    331331
    332     do while (jmod <= size(yjmod))
    333       do while (yjmod(jmod) > yjdat(jdat))
     332    DO while (jmod <= size(yjmod))
     333      DO while (yjmod(jmod) > yjdat(jdat))
    334334        dy = yjdat(jdat) - y0
    335335        dym = dym + dy

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/interpost.f90

    r5136 r5158  
    2020  ! On passe donc des niveaux de Lin à ceux du LMDZ
    2121
    22   do l = 1, llm
    23     do j = 1, jjp1
    24       do i = 1, iim
     22  DO l = 1, llm
     23    DO j = 1, jjp1
     24      DO i = 1, iim
    2525        q(i, j, l) = qppm(i, j, llm - l + 1)
    2626      enddo
    … …  
    3030  ! BOUCLAGE EN LONGITUDE PAS EFFECTUE DANS PPM3D
    3131
    32   do l = 1, llm
    33     do j = 1, jjp1
     32  DO l = 1, llm
     33    DO j = 1, jjp1
    3434      q(iip1, j, l) = q(1, j, l)
    3535    enddo

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/interpre.f90

    r5140 r5158  
    4343  ! la vectorialisation
    4444
    45   do j = 1, jjp1
    46     do i = 1, iip1
     45  DO j = 1, jjp1
     46    DO i = 1, iip1
    4747      smass(i, j) = 0.
    4848    enddo
    4949  enddo
    5050
    51   do l = 1, llm
    52     do j = 1, jjp1
    53       do i = 1, iip1
     51  DO l = 1, llm
     52    DO j = 1, jjp1
     53      DO i = 1, iip1
    5454        smass(i, j) = smass(i, j) + masse(i, j, l)
    5555      enddo
    … …  
    5757  enddo
    5858
    59   do j = 1, jjp1
    60     do i = 1, iim
     59  DO j = 1, jjp1
     60    DO i = 1, iim
    6161      psppm(i, j) = smass(i, j) / aire(i, j) * g * 0.01
    6262    END DO
    … …  
    6767  ! de vitesse et pas les flux, on doit donc passer de l'un à l'autre
    6868  ! Dans le même temps, on fait le changement d'orientation du vent en v
    69   do l = 1, llm
    70     do j = 1, jjm
    71       do i = 1, iip1
     69  DO l = 1, llm
     70    DO j = 1, jjm
     71      DO i = 1, iip1
    7272        vnat(i, j, l) = -pbarv(i, j, l) / masseby(i, j, l) * cv(i, j)
    7373      enddo
    7474    enddo
    75     do  i = 1, iim
     75    DO  i = 1, iim
    7676      vnat(i, jjp1, l) = 0.
    7777    enddo
    78     do j = 1, jjp1
    79       do i = 1, iip1
     78    DO j = 1, jjp1
     79      DO i = 1, iip1
    8080        unat(i, j, l) = pbaru(i, j, l) / massebx(i, j, l) * cu(i, j)
    8181      enddo
    … …  
    8686  ! Flux en l=1 (sol) nul
    8787  fluxw = 0.
    88   do l = 1, llm
    89     do j = 1, jjp1
    90       do i = 1, iip1
     88  DO l = 1, llm
     89    DO j = 1, jjp1
     90      DO i = 1, iip1
    9191        fluxw(i, j, l) = w(i, j, l) * g * 0.01 / aire(i, j)
    9292        ! PRINT*,i,j,l,'fluxw(i,j,l)=',fluxw(i,j,l),
    … …  
    101101  ! On passe donc des niveaux du LMDZ à ceux de Lin
    102102
    103   do l = 1, llm + 1
     103  DO l = 1, llm + 1
    104104    apppm(l) = ap(llm + 2 - l)
    105105    bpppm(l) = bp(llm + 2 - l)
    106106  enddo
    107107
    108   do l = 1, llm
    109     do j = 1, jjp1
    110       do i = 1, iim
     108  DO l = 1, llm
     109    DO j = 1, jjp1
     110      DO i = 1, iim
    111111        unatppm(i, j, l) = unat(i, j, llm - l + 1)
    112112        vnatppm(i, j, l) = vnat(i, j, llm - l + 1)

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/invert_lat.F90

    r3104 r5158  
    1414        DO j=1,ysize
    1515            f_aux(:,j,l)=field(:,ysize+1-j,l)
    16         END DO
     16    END DO
    1717    END DO
    1818   

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/invert_zoom_x_m.F90

    r5134 r5158  
    3737
    3838       it = 2 * nmax
    39        do while (xfi < xf(it) .AND. it >= 1)
     39       DO while (xfi < xf(it) .AND. it >= 1)
    4040          it = it - 1
    4141       END DO

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/limx.f90

    r5136 r5158  
    5555  !   calcul de la pente a droite et a gauche de la maille
    5656
    57   do l = 1, llm
    58      do ij=iip2,ip1jm-1
     57  DO l = 1, llm
     58     DO ij=iip2,ip1jm-1
    5959        dxqu(ij)=q(ij+1,l)-q(ij,l)
    6060     enddo
    61      do ij=iip1+iip1,ip1jm,iip1
     61     DO ij=iip1+iip1,ip1jm,iip1
    6262        dxqu(ij)=dxqu(ij-iim)
    6363     enddo
    6464
    65      do ij=iip2,ip1jm
     65     DO ij=iip2,ip1jm
    6666        adxqu(ij)=abs(dxqu(ij))
    6767     enddo
    … …  
    6969  !   calcul de la pente maximum dans la maille en valeur absolue
    7070
    71      do ij=iip2+1,ip1jm
     71     DO ij=iip2+1,ip1jm
    7272        dxqmax(ij)=pente_max*min(adxqu(ij-1),adxqu(ij))
    7373     enddo
    7474
    75      do ij=iip1+iip1,ip1jm,iip1
     75     DO ij=iip1+iip1,ip1jm,iip1
    7676        dxqmax(ij-iim)=dxqmax(ij)
    7777     enddo
    … …  
    7979  !   calcul de la pente avec limitation
    8080
    81      do ij=iip2+1,ip1jm
     81     DO ij=iip2+1,ip1jm
    8282        IF(     dxqu(ij-1)*dxqu(ij)>0. &
    8383              .AND. dxq(ij,l)*dxqu(ij)>0.) THEN
    … …  
    8989        endif
    9090     enddo
    91      do ij=iip1+iip1,ip1jm,iip1
     91     DO ij=iip1+iip1,ip1jm,iip1
    9292        dxq(ij-iim,l)=dxq(ij,l)
    9393     enddo

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/limy.f90

    r5136 r5158  
    1010  !    ********************************************************************
    1111  ! q,w sont des arguments d'entree  pour le s-pg ....
    12   ! dq         sont des arguments de sortie pour le s-pg ....
     12  ! dq            sont des arguments de sortie pour le s-pg ....
    1313  !
    1414  !
    … …  
    5555     PRINT*,'SCHEMA AMONT NOUVEAU'
    5656     first=.FALSE.
    57      do i=2,iip1
     57     DO i=2,iip1
    5858        coslon(i)=cos(rlonv(i))
    5959        sinlon(i)=sin(rlonv(i))
    … …  
    6969  !
    7070
    71   do l = 1, llm
     71  DO l = 1, llm
    7272  !
    7373     DO ij=1,ip1jmp1
    … …  
    9595  !   calcul des pentes aux points v
    9696
    97   do ij=1,ip1jm
     97  DO ij=1,ip1jm
    9898     dyqv(ij)=q(ij,l)-q(ij+iip1,l)
    9999     adyqv(ij)=abs(dyqv(ij))
    … …  
    102102  !   calcul des pentes aux points scalaires
    103103
    104   do ij=iip2,ip1jm
     104  DO ij=iip2,ip1jm
    105105     dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij))
    106106     dyqmax(ij)=pente_max*dyqmax(ij)
    … …  
    149149  IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1))<=0.) &
    150150        THEN
    151      do ij=1,iip1
     151     DO ij=1,iip1
    152152        dyqmax(ij)=0.
    153153     enddo
    154154  else
    155      do ij=1,iip1
     155     DO ij=1,iip1
    156156        dyqmax(ij)=pente_max*abs(dyqv(ij))
    157157     enddo
    … …  
    161161        dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)<=0.) &
    162162        THEN
    163      do ij=ip1jm+1,ip1jmp1
     163     DO ij=ip1jm+1,ip1jmp1
    164164        dyqmax(ij)=0.
    165165     enddo
    166166  else
    167      do ij=ip1jm+1,ip1jmp1
     167     DO ij=ip1jm+1,ip1jmp1
    168168        dyqmax(ij)=pente_max*abs(dyqv(ij-iip1))
    169169     enddo
    … …  
    172172  !   calcul des pentes limitees
    173173
    174   do ij=1,ip1jmp1 ! cf below: should it be ip1jm instead ?
     174  DO ij=1,ip1jmp1 ! cf below: should it be ip1jm instead ?
    175175     IF(dyqv(ij)*dyqv(ij-iip1)>0.) then  ! /!\ causes Warning: iteration 1056 invokes undefined behavior [-Waggressive-loop-optimizations] in 32x32x39
    176176        dyq(ij)=sign(min(abs(dyq(ij)),dyqmax(ij)),dyq(ij))

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/limz.f90

    r5136 r5158  
    5555
    5656  !   calcul de la pente en haut et en bas de la maille
    57    do ij=1,ip1jmp1
    58    do l = 1, llm-1
     57   DO ij=1,ip1jmp1
     58   DO l = 1, llm-1
    5959        dzqw(l)=q(ij,l+1)-q(ij,l)
    6060     enddo
    6161        dzqw(llm)=0.
    6262
    63      do  l=1,llm
     63     DO  l=1,llm
    6464        adzqw(l)=abs(dzqw(l))
    6565     enddo
    … …  
    6767  !   calcul de la pente maximum dans la maille en valeur absolue
    6868
    69      do l=2,llm-1
     69     DO l=2,llm-1
    7070        dzqmax(l)=pente_max*min(adzqw(l-1),adzqw(l))
    7171     enddo
    … …  
    7373  !   calcul de la pente avec limitation
    7474
    75      do l=2,llm-1
     75     DO l=2,llm-1
    7676        IF(     dzqw(l-1)*dzqw(l)>0. &
    7777              .AND. dzq(ij,l)*dzqw(l)>0.) THEN

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/pentes_ini.f90

    r5136 r5158  
    8686     PRINT*,'SCHEMA AMONT NOUVEAU'
    8787     first=.FALSE.
    88      do i=2,iip1
     88     DO i=2,iip1
    8989        coslon(i)=cos(rlonv(i))
    9090        sinlon(i)=sin(rlonv(i))
    … …  
    187187  !CC
    188188   IF(mode==2) THEN
    189       do l=1,llm
     189      DO l=1,llm
    190190        s0s=0.
    191191        s0n=0.
    … …  
    196196        smn=0.
    197197        sms=0.
    198         do i=1,iim
     198        DO i=1,iim
    199199           smn=smn+sm(i,1,l)
    200200           sms=sms+sm(i,jjp1,l)
    … …  
    208208           dys2=dys2+coslondlon(i)*zz
    209209        enddo
    210         do i=1,iim
     210        DO i=1,iim
    211211           sy(i,1,l)=dyn1*sinlon(i)+dyn2*coslon(i)
    212212           sy(i,jjp1,l)=dys1*sinlon(i)+dys2*coslon(i)
    213213        enddo
    214         do i=1,iim
     214        DO i=1,iim
    215215           s0(i,1,l)=s0n/smn+sy(i,1,l)
    216216           s0(i,jjp1,l)=s0s/sms-sy(i,jjp1,l)
    … …  
    220220        s0(iip1,jjp1,l)=s0(1,jjp1,l)
    221221
    222         do i=1,iim
     222        DO i=1,iim
    223223           sxn(i)=s0(i+1,1,l)-s0(i,1,l)
    224224           sxs(i)=s0(i+1,jjp1,l)-s0(i,jjp1,l)
    225225  !   on rerentre les masses
    226226        enddo
    227         do i=1,iim
     227        DO i=1,iim
    228228           sy(i,1,l)=sy(i,1,l)*sm(i,1,l)
    229229           sy(i,jjp1,l)=sy(i,jjp1,l)*sm(i,jjp1,l)
    … …  
    233233        sxn(iip1)=sxn(1)
    234234        sxs(iip1)=sxs(1)
    235         do i=1,iim
     235        DO i=1,iim
    236236           sx(i+1,1,l)=0.25*(sxn(i)+sxn(i+1))*sm(i+1,1,l)
    237237           sx(i+1,jjp1,l)=0.25*(sxs(i)+sxs(i+1))*sm(i+1,jjp1,l)
    … …  
    247247
    248248  IF (mode==4) THEN
    249      do l=1,llm
    250         do i=1,iip1
     249     DO l=1,llm
     250        DO i=1,iip1
    251251           sx(i,1,l)=0.
    252252           sx(i,jjp1,l)=0.
    … …  
    261261  ! CALL minmaxq(zq,1.e33,-1.e33,'avant advy     ')
    262262  IF (mode==4) THEN
    263      do l=1,llm
    264         do i=1,iip1
     263     DO l=1,llm
     264        DO i=1,iip1
    265265           sx(i,1,l)=0.
    266266           sx(i,jjp1,l)=0.
    … …  
    273273   CALL advy( limit,.5*dtvr,pbarv,sm,s0,sx,sy,sz )
    274274  ! CALL minmaxq(zq,1.e33,-1.e33,'avant advz     ')
    275    do j=1,jjp1
    276       do i=1,iip1
     275   DO j=1,jjp1
     276      DO i=1,iip1
    277277         sz(i,j,1)=0.
    278278         sz(i,j,llm)=0.
    … …  
    282282   CALL advz( limit,dtvr,w,sm,s0,sx,sy,sz )
    283283  IF (mode==4) THEN
    284      do l=1,llm
    285         do i=1,iip1
     284     DO l=1,llm
     285        DO i=1,iip1
    286286           sx(i,1,l)=0.
    287287           sx(i,jjp1,l)=0.
    … …  
    293293    CALL limy(s0,sy,sm,pente_max)
    294294   CALL advy( limit,.5*dtvr,pbarv,sm,s0,sx,sy,sz )
    295    do l=1,llm
    296       do j=1,jjp1
     295   DO l=1,llm
     296      DO j=1,jjp1
    297297         sm(iip1,j,l)=sm(1,j,l)
    298298         s0(iip1,j,l)=s0(1,j,l)
    … …  
    306306  ! CALL minmaxq(zq,1.e33,-1.e33,'avant advx     ')
    307307  IF (mode==4) THEN
    308      do l=1,llm
    309         do i=1,iip1
     308     DO l=1,llm
     309        DO i=1,iip1
    310310           sx(i,1,l)=0.
    311311           sx(i,jjp1,l)=0.
    … …  
    354354     dqzpn=ssum(iim,sz(1,1,l),1)/masn
    355355     dqzps=ssum(iim,sz(1,jjp1,l),1)/mass
    356      do i=1,iip1
     356     DO i=1,iip1
    357357        q( i,1,llm+1-l,3)=dqzpn
    358358        q( i,jjp1,llm+1-l,3)=dqzps
    … …  
    365365        dyn2=0.
    366366        dys2=0.
    367         do i=1,iim
     367        DO i=1,iim
    368368           dyn1=dyn1+sinlondlon(i)*sy(i,1,l)/sm(i,1,l)
    369369           dyn2=dyn2+coslondlon(i)*sy(i,1,l)/sm(i,1,l)
    … …  
    371371           dys2=dys2+coslondlon(i)*sy(i,jjp1,l)/sm(i,jjp1,l)
    372372        enddo
    373         do i=1,iim
     373        DO i=1,iim
    374374           q(i,1,llm+1-l,2)= &
    375375                 (sinlon(i)*dyn1+coslon(i)*dyn2)
    … …  
    387387        dyn2=0.
    388388        dys2=0.
    389         do i=1,iim
     389        DO i=1,iim
    390390           zz=s0(i,2,l)/sm(i,2,l)-q(i,1,llm+1-l,0)
    391391           dyn1=dyn1+sinlondlon(i)*zz
    … …  
    395395           dys2=dys2+coslondlon(i)*zz
    396396        enddo
    397         do i=1,iim
     397        DO i=1,iim
    398398           q(i,1,llm+1-l,2)= &
    399399                 (sinlon(i)*dyn1+coslon(i)*dyn2)/2.
    … …  
    407407        q(iip1,jjp1,llm+1-l,0)=q(1,jjp1,llm+1-l,0)
    408408
    409         do i=1,iim
     409        DO i=1,iim
    410410           sxn(i)=q(i+1,1,llm+1-l,0)-q(i,1,llm+1-l,0)
    411411           sxs(i)=q(i+1,jjp1,llm+1-l,0)-q(i,jjp1,llm+1-l,0)
    … …  
    413413        sxn(iip1)=sxn(1)
    414414        sxs(iip1)=sxs(1)
    415         do i=1,iim
     415        DO i=1,iim
    416416           q(i+1,1,llm+1-l,1)=0.25*(sxn(i)+sxn(i+1))
    417417           q(i+1,jjp1,llm+1-l,1)=0.25*(sxs(i)+sxs(i+1))
    … …  
    426426
    427427  ! bouclage en longitude
    428   do iq=0,3
    429      do l=1,llm
    430         do j=1,jjp1
     428  DO iq=0,3
     429     DO l=1,llm
     430        DO j=1,jjp1
    431431           q(iip1,j,l,iq)=q(1,j,l,iq)
    432432        enddo
    … …  
    455455    ! PRINT*, '-------------------------------------------'
    456456
    457    do l=1,llm
    458       do j=1,jjp1
    459        do i=1,iip1
     457   DO l=1,llm
     458      DO j=1,jjp1
     459       DO i=1,iip1
    460460         IF(q(i,j,l,0)<qmin) &
    461461               PRINT*,'apres pentes, s0(',i,',',j,',',l,')=',q(i,j,l,0)

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/ppm3d.f90

    r5117 r5158  
    361361  ENDIF
    362362  !
    363   do J=2,JMR
     363  DO J=2,JMR
    364364  acosp(j) = 1. / cosp(j)
    365365  END DO
    … …  
    401401  !
    402402  !
    403   do J=2,JMR
     403  DO J=2,JMR
    404404  DTDX(j)  = DT / ( DL*AE*COSP(J) )
    405405
    … …  
    419419  !
    420420  ! delp = pressure thickness: the psudo-density in a hydrostatic system.
    421   do  k=1,NLAY
    422      do  j=1,JNP
    423         do  i=1,IMR
     421  DO  k=1,NLAY
     422     DO  j=1,JNP
     423        DO  i=1,IMR
    424424           delp1(i,j,k)=DAP(k)+DBK(k)*PS1(i,j)
    425425           delp2(i,j,k)=DAP(k)+DBK(k)*PS2(i,j)
    … …  
    451451  END DO
    452452  !
    453   do k=1,NLAY
     453  DO k=1,NLAY
    454454  !
    455455  IF(IGD==0) THEN
    … …  
    458458  else
    459459  ! Convert winds on C-grid to Courant #
    460   do j=j1,j2
    461   do i=2,IMR
     460  DO j=j1,j2
     461  DO i=2,IMR
    462462  CRX(i,J) = dtdx(j)*U(i-1,j,k)
    463463  END DO
    … …  
    465465
    466466  !
    467   do j=j1,j2
     467  DO j=j1,j2
    468468  CRX(1,J) = dtdx(j)*U(IMR,j,k)
    469469  END DO
    470470  !
    471   do i=1,IMR*JMR
     471  DO i=1,IMR*JMR
    472472  CRY(i,2) = DTDY*V(i,1,k)
    473473  END DO
    … …  
    478478  JN = j2
    479479  !
    480   do j=JS0,j1+1,-1
    481   do i=1,IMR
     480  DO j=JS0,j1+1,-1
     481  DO i=1,IMR
    482482  IF(abs(CRX(i,j))>1.) THEN
    483483        JS = j
    … …  
    488488  !
    4894892222   continue
    490   do j=JN0,j2-1
    491   do i=1,IMR
     490  DO j=JN0,j2-1
     491  DO i=1,IMR
    492492  IF(abs(CRX(i,j))>1.) THEN
    493493        JN = j
    … …  
    499499  !
    500500  IF(j1/=2) then           ! Enlarged polar cap.
    501   do i=1,IMR
     501  DO i=1,IMR
    502502  DPI(i,  2,k) = 0.
    503503  DPI(i,JMR,k) = 0.
    … …  
    508508  !
    509509  ! N-S component
    510   do j=j1,j2+1
     510  DO j=j1,j2+1
    511511  D5 = 0.5 * COSE(j)
    512   do i=1,IMR
     512  DO i=1,IMR
    513513  ymass(i,j) = CRY(i,j)*D5*(delp2(i,j,k) + delp2(i,j-1,k))
    514514  enddo
    515515  enddo
    516516  !
    517   do j=j1,j2
     517  DO j=j1,j2
    518518  DO i=1,IMR
    519519  DPI(i,j,k) = (ymass(i,j) - ymass(i,j+1)) * acosp(j)
    … …  
    524524  sum1 = ymass(IMR,j1  )
    525525  sum2 = ymass(IMR,J2+1)
    526   do i=1,IMR-1
     526  DO i=1,IMR-1
    527527  sum1 = sum1 + ymass(i,j1  )
    528528  sum2 = sum2 + ymass(i,J2+1)
    … …  
    531531  sum1 = - sum1 * RCAP
    532532  sum2 =   sum2 * RCAP
    533   do i=1,IMR
     533  DO i=1,IMR
    534534  DPI(i,  1,k) = sum1
    535535  DPI(i,JNP,k) = sum2
    … …  
    538538  ! E-W component
    539539  !
    540   do j=j1,j2
    541   do i=2,IMR
     540  DO j=j1,j2
     541  DO i=2,IMR
    542542  PU(i,j) = 0.5 * (delp2(i,j,k) + delp2(i-1,j,k))
    543543  enddo
    544544  enddo
    545545  !
    546   do j=j1,j2
     546  DO j=j1,j2
    547547  PU(1,j) = 0.5 * (delp2(1,j,k) + delp2(IMR,j,k))
    548548  enddo
    549549  !
    550   do j=j1,j2
     550  DO j=j1,j2
    551551  DO i=1,IMR
    552552  xmass(i,j) = PU(i,j)*CRX(i,j)
    … …  
    565565  !
    566566  DO j=j1,j2
    567   do i=1,IMR-1
     567  DO i=1,IMR-1
    568568  UA(i,j) = 0.5 * (CRX(i,j)+CRX(i+1,j))
    569569  enddo
    … …  
    576576  ! Rajouts pour LMDZ.3.3
    577577  !cccccccccccccccccccccccccccccccccccccccccccccccccccccc
    578   do i=1,IMR
    579      do j=1,JNP
     578  DO i=1,IMR
     579     DO j=1,JNP
    580580         VA(i,j)=0.
    581581     enddo
    582582  enddo
    583583
    584   do i=1,imr*(JMR-1)
     584  DO i=1,imr*(JMR-1)
    585585  VA(i,2) = 0.5*(CRY(i,2)+CRY(i,3))
    586586  enddo
    … …  
    588588  IF(j1==2) THEN
    589589    IMH = IMR/2
    590   do i=1,IMH
     590  DO i=1,IMH
    591591  VA(i,      1) = 0.5*(CRY(i,2)-CRY(i+IMH,2))
    592592  VA(i+IMH,  1) = -VA(i,1)
    … …  
    599599  !
    600600  ! ****6***0*********0*********0*********0*********0*********0**********72
    601   do IC=1,NC
    602   !
    603   do i=1,IMJM
     601  DO IC=1,NC
     602  !
     603  DO i=1,IMJM
    604604  wk1(i,1,1) = 0.
    605605  wk1(i,1,2) = 0.
    … …  
    607607  !
    608608  ! E-W advective cross term
    609   do j=J1,J2
     609  DO j=J1,J2
    610610  IF(J>JS  .AND. J<JN) GO TO 250
    611611  !
    612   do i=1,IMR
     612  DO i=1,IMR
    613613  qtmp(i) = q(i,j,k,IC)
    614614  enddo
    615615  !
    616   do i=-IML,0
     616  DO i=-IML,0
    617617  qtmp(i)       = q(IMR+i,j,k,IC)
    618618  qtmp(IMR+1-i) = q(1-i,j,k,IC)
    … …  
    634634  !
    635635  IF(JN/=0) THEN
    636   do j=JS+1,JN-1
    637   !
    638   do i=1,IMR
     636  DO j=JS+1,JN-1
     637  !
     638  DO i=1,IMR
    639639  qtmp(i) = q(i,j,k,IC)
    640640  enddo
    … …  
    643643  qtmp(IMR+1) = q(  1,J,k,IC)
    644644  !
    645   do i=1,imr
     645  DO i=1,imr
    646646  iu = i - UA(i,j)
    647647  wk1(i,j,1) = UA(i,j)*(qtmp(iu) - qtmp(iu+1))
    … …  
    651651  ! ****6***0*********0*********0*********0*********0*********0**********72
    652652  ! Contribution from the N-S advection
    653   do i=1,imr*(j2-j1+1)
     653  DO i=1,imr*(j2-j1+1)
    654654  JT = REAL(J1) - VA(i,j1)
    655655  wk1(i,j1,2) = VA(i,j1) * (q(i,jt,k,IC) - q(i,jt+1,k,IC))
    656656  enddo
    657657  !
    658   do i=1,IMJM
     658  DO i=1,IMJM
    659659  wk1(i,1,1) = q(i,1,k,IC) + 0.5*wk1(i,1,1)
    660660  wk1(i,1,2) = q(i,1,k,IC) + 0.5*wk1(i,1,2)
    … …  
    676676  CALL xadv(IMR,JNP,j1,j2,wk1(1,1,2),UA,JS,JN,IML,DC2,iad)
    677677  CALL yadv(IMR,JNP,j1,j2,wk1(1,1,1),VA,PV,W,jad)
    678   do j=1,JNP
    679   do i=1,IMR
     678  DO j=1,JNP
     679  DO i=1,IMR
    680680  q(i,j,k,IC) = q(i,j,k,IC) + DC2(i,j) + PV(i,j)
    681681  enddo
    … …  
    696696  ! 1st step: compute total column mass CONVERGENCE.
    697697  !
    698   do j=1,JNP
    699   do i=1,IMR
     698  DO j=1,JNP
     699  DO i=1,IMR
    700700  CRY(i,j) = DPI(i,j,1)
    701701  END DO
    702702  END DO
    703703  !
    704   do k=2,NLAY
    705   do j=1,JNP
    706   do i=1,IMR
     704  DO k=2,NLAY
     705  DO j=1,JNP
     706  DO i=1,IMR
    707707  CRY(i,j)  = CRY(i,j) + DPI(i,j,k)
    708708  END DO
    … …  
    710710  END DO
    711711  !
    712   do j=1,JNP
    713   do i=1,IMR
     712  DO j=1,JNP
     713  DO i=1,IMR
    714714  !
    715715  ! 2nd step: compute PS2 (PS at n+1) using the hydrostatic assumption.
    … …  
    725725  END DO
    726726  !
    727   do k=2,NLAY-1
    728   do j=1,JNP
    729   do i=1,IMR
     727  DO k=2,NLAY-1
     728  DO j=1,JNP
     729  DO i=1,IMR
    730730  W(i,j,k) = W(i,j,k-1) + DPI(i,j,k) - DBK(k)*CRY(i,j)
    731731  END DO
    … …  
    742742  !
    743743    KRD = max(3, KORD)
    744   do IC=1,NC
     744  DO IC=1,NC
    745745  !
    746746  !****6***0*********0*********0*********0*********0*********0**********72
    … …  
    814814  ! ****6***0*********0*********0*********0*********0*********0**********72
    815815  !
    816   do k=1,NLAYM1
    817   do i=1,IMJM
     816  DO k=1,NLAYM1
     817  DO i=1,IMJM
    818818  DQDT(i,1,k) = P(i,1,k+1) - P(i,1,k)
    819819  END DO
    … …  
    909909  END DO
    910910  !
    911   do i=1,IMR*NLAYM1
     911  DO i=1,IMR*NLAYM1
    912912  AR(i,1) = AL(i,2)
    913913   ! print *,'AR1',i,AR(i,1)
    914914  END DO
    915915  !
    916   do i=1,IMR*NLAY
     916  DO i=1,IMR*NLAY
    917917  A6(i,1) = 3.*(wk1(i,1)+wk1(i,1) - (AL(i,1)+AR(i,1)))
    918918   ! print *,'A61',i,A6(i,1)
    … …  
    949949  END DO
    950950  !
    951   do i=1,IMR
     951  DO i=1,IMR
    952952  DQ(i,j,   1) = DQ(i,j,   1) - flux(i,   2)
    953953  DQ(i,j,NLAY) = DQ(i,j,NLAY) + flux(i,NLAY)
    954954  END DO
    955955  !
    956   do k=2,NLAYM1
    957   do i=1,IMR
     956  DO k=2,NLAYM1
     957  DO i=1,IMR
    958958  DQ(i,j,k) = DQ(i,j,k) + flux(i,k) - flux(i,k+1)
    959959  END DO
    … …  
    984984  j2vl = j2-jvan
    985985  !
    986   do j=j1,j2
    987   !
    988   do i=1,IMR
     986  DO j=j1,j2
     987  !
     988  DO i=1,IMR
    989989  qtmp(i) = q(i,j)
    990990  enddo
    … …  
    102810282222   continue
    10291029  !
    1030   do i=-IML,0
     1030  DO i=-IML,0
    10311031  qtmp(i)     = q(IMR+i,j)
    10321032  qtmp(IMP-i) = q(1-i,j)
    … …  
    10431043  CALL xmist(IMR,IML,Qtmp,DC)
    10441044  !
    1045   do i=-IML,0
     1045  DO i=-IML,0
    10461046  DC(i)     = DC(IMR+i)
    10471047  DC(IMP-i) = DC(1-i)
    … …  
    10571057  ENDIF
    10581058  !
    1059   do i=1,IMR
     1059  DO i=1,IMR
    10601060  IF(uc(i,j)>1.) THEN
    10611061  !DIR$ NOVECTOR
    1062     do ist = ISAVE(i),i-1
     1062    DO ist = ISAVE(i),i-1
    10631063    fx1(i) = fx1(i) + qtmp(ist)
    10641064    enddo
    10651065  elseIF(uc(i,j)<-1.) THEN
    1066     do ist = i,ISAVE(i)-1
     1066    DO ist = i,ISAVE(i)-1
    10671067    fx1(i) = fx1(i) - qtmp(ist)
    10681068    enddo
    … …  
    10701070  ENDIF
    10711071  END DO
    1072   do i=1,IMR
     1072  DO i=1,IMR
    10731073  fx1(i) = PU(i,j)*fx1(i)
    10741074  enddo
    … …  
    11231123  END DO
    11241124  !
    1125   do i=1,IMR-1
     1125  DO i=1,IMR-1
    11261126  AR(i) = AL(i+1)
    11271127  END DO
    11281128  AR(IMR) = AL(1)
    11291129  !
    1130   do i=1,IMR
     1130  DO i=1,IMR
    11311131  A6(i) = 3.*(p(i)+p(i)  - (AL(i)+AR(i)))
    11321132  END DO
    … …  
    11581158  REAL :: tmp,pmax,pmin
    11591159  !
    1160   do i=1,IMR
     1160  DO i=1,IMR
    11611161  tmp = R24*(8.*(p(i+1) - p(i-1)) + p(i-2) - p(i+2))
    11621162  Pmax = max(P(i-1), p(i), p(i+1)) - p(i)
    … …  
    12151215  sum1 = fx(IMR,j1  )
    12161216  sum2 = fx(IMR,J2+1)
    1217   do i=1,IMR-1
     1217  DO i=1,IMR-1
    12181218  sum1 = sum1 + fx(i,j1  )
    12191219  sum2 = sum2 + fx(i,J2+1)
    … …  
    12221222  sum1 = DQ(1,  1) - sum1 * RCAP
    12231223  sum2 = DQ(1,JNP) + sum2 * RCAP
    1224   do i=1,IMR
     1224  DO i=1,IMR
    12251225  DQ(i,  1) = sum1
    12261226  DQ(i,JNP) = sum2
    … …  
    12281228  !
    12291229  IF(j1/=2) THEN
    1230   do i=1,IMR
     1230  DO i=1,IMR
    12311231  DQ(i,  2) = sum1
    12321232  DQ(i,JMR) = sum2
    … …  
    12501250  !
    12511251  IF(ID==2) THEN
    1252   do i=1,IMR*(JMR-1)
     1252  DO i=1,IMR*(JMR-1)
    12531253  tmp = 0.25*(p(i,3) - p(i,1))
    12541254  Pmax = max(p(i,1),p(i,2),p(i,3)) - p(i,2)
    … …  
    12571257  END DO
    12581258  ELSE
    1259   do i=1,IMH
     1259  DO i=1,IMH
    12601260  ! J=2
    12611261  tmp = (8.*(p(i,3) - p(i,1)) + p(i+IMH,2) - p(i,4))*R24
    … …  
    12691269  DC(i,JMR) = sign(min(abs(tmp),Pmin,Pmax),tmp)
    12701270  END DO
    1271   do i=IMH+1,IMR
     1271  DO i=IMH+1,IMR
    12721272  ! J=2
    12731273  tmp = (8.*(p(i,3) - p(i,1)) + p(i-IMH,2) - p(i,4))*R24
    … …  
    12821282  END DO
    12831283  !
    1284   do i=1,IJM3
     1284  DO i=1,IJM3
    12851285  tmp = (8.*(p(i,4) - p(i,2)) + p(i,1) - p(i,5))*R24
    12861286  Pmax = max(p(i,2),p(i,3),p(i,4)) - p(i,3)
    … …  
    12911291  !
    12921292  IF(j1/=2) THEN
    1293   do i=1,IMR
     1293  DO i=1,IMR
    12941294  DC(i,1) = 0.
    12951295  DC(i,JNP) = 0.
    … …  
    12981298  ! Determine slopes in polar caps for scalars!
    12991299  !
    1300   do i=1,IMH
     1300  DO i=1,IMH
    13011301  ! South
    13021302  tmp = 0.25*(p(i,2) - p(i+imh,2))
    … …  
    13111311  END DO
    13121312  !
    1313   do i=imh+1,IMR
     1313  DO i=imh+1,IMR
    13141314  DC(i,  1) =  - DC(i-imh,  1)
    13151315  DC(i,JNP) =  - DC(i-imh,JNP)
    … …  
    13791379
    13801380
    1381   do i=1,len
     1381  DO i=1,len
    13821382  A6(i,j11) = 3.*(p(i,j11)+p(i,j11)  - (AL(i,j11)+AR(i,j11)))
    13831383  END DO
    … …  
    14091409    JMR = JNP-1
    14101410    IMH = IMR/2
    1411     do j=1,JNP
    1412     do i=1,IMR
     1411    DO j=1,JNP
     1412    DO i=1,IMR
    14131413    wk(i,j) = p(i,j)
    14141414    enddo
    14151415    enddo
    14161416  ! Poles:
    1417     do i=1,IMH
     1417    DO i=1,IMH
    14181418    wk(i,   -1) = p(i+IMH,3)
    14191419    wk(i+IMH,-1) = p(i,3)
    … …  
    14281428  ! --------------------------------
    14291429  IF(IAD==2) THEN
    1430   do j=j1-1,j2+1
    1431   do i=1,IMR
     1430  DO j=j1-1,j2+1
     1431  DO i=1,IMR
    14321432   ! WRITE(*,*) 'avt NINT','i=',i,'j=',j
    14331433  JP = NINT(VA(i,j))
    … …  
    14451445  !
    14461446  ELSEIF(IAD==1) THEN
    1447     do j=j1-1,j2+1
    1448   do i=1,imr
     1447    DO j=j1-1,j2+1
     1448  DO i=1,imr
    14491449  JP = REAL(j)-VA(i,j)
    14501450  ady(i,j) = VA(i,j)*(wk(i,jp)-wk(i,jp+1))
    … …  
    14561456    sum1 = 0.
    14571457    sum2 = 0.
    1458   do i=1,imr
     1458  DO i=1,imr
    14591459  sum1 = sum1 + ady(i,2)
    14601460  sum2 = sum2 + ady(i,JMR)
    … …  
    14631463    sum2 = sum2 / IMR
    14641464  !
    1465   do i=1,imr
     1465  DO i=1,imr
    14661466  ady(i,  2) =  sum1
    14671467  ady(i,JMR) =  sum2
    … …  
    14731473    sum1 = 0.
    14741474    sum2 = 0.
    1475   do i=1,imr
     1475  DO i=1,imr
    14761476  sum1 = sum1 + ady(i,1)
    14771477  sum2 = sum2 + ady(i,JNP)
    … …  
    14801480    sum2 = sum2 / IMR
    14811481  !
    1482   do i=1,imr
     1482  DO i=1,imr
    14831483  ady(i,  1) =  sum1
    14841484  ady(i,JNP) =  sum2
    … …  
    14971497  !
    14981498    JMR = JNP-1
    1499   do j=j1,j2
     1499  DO j=j1,j2
    15001500  IF(J>JS  .AND. J<JN) GO TO 1309
    15011501  !
    1502   do i=1,IMR
     1502  DO i=1,IMR
    15031503  qtmp(i) = p(i,j)
    15041504  enddo
    15051505  !
    1506   do i=-IML,0
     1506  DO i=-IML,0
    15071507  qtmp(i)       = p(IMR+i,j)
    15081508  qtmp(IMR+1-i) = p(1-i,j)
    … …  
    15311531  ENDIF
    15321532  !
    1533   do i=1,IMR
     1533  DO i=1,IMR
    15341534  adx(i,j) = adx(i,j) - p(i,j)
    15351535  enddo
    … …  
    15391539  ! Eulerian upwind
    15401540  !
    1541   do j=JS+1,JN-1
    1542   !
    1543   do i=1,IMR
     1541  DO j=JS+1,JN-1
     1542  !
     1543  DO i=1,IMR
    15441544  qtmp(i) = p(i,j)
    15451545  enddo
    … …  
    15511551  qtmp(-1)     = p(IMR-1,J)
    15521552  qtmp(IMR+2) = p(2,J)
    1553   do i=1,imr
     1553  DO i=1,imr
    15541554  IP = NINT(UA(i,j))
    15551555  ru = IP - UA(i,j)
    … …  
    15691569  !
    15701570    IF(j1/=2) THEN
    1571   do i=1,IMR
     1571  DO i=1,IMR
    15721572  adx(i,  2) = 0.
    15731573  adx(i,JMR) = 0.
    … …  
    15751575    endif
    15761576  ! set cross term due to x-adv at the poles to zero.
    1577   do i=1,IMR
     1577  DO i=1,IMR
    15781578  adx(i,  1) = 0.
    15791579  adx(i,JNP) = 0.
    … …  
    16061606  IF(LMT==0) THEN
    16071607  ! Full constraint
    1608   do i=1,IM
     1608  DO i=1,IM
    16091609  IF(DC(i)==0.) THEN
    16101610        AR(i) = p(i)
    … …  
    16261626  elseif(LMT==1) THEN
    16271627  ! Semi-monotonic constraint
    1628   do i=1,IM
     1628  DO i=1,IM
    16291629  IF(abs(AR(i)-AL(i)) >= -A6(i)) go to 150
    16301630  IF(p(i)<AR(i) .AND. p(i)<AL(i)) THEN
    … …  
    16421642  END DO
    16431643  elseif(LMT==2) THEN
    1644   do i=1,IM
     1644  DO i=1,IM
    16451645  IF(abs(AR(i)-AL(i)) >= -A6(i)) go to 250
    16461646  fmin = p(i) + 0.25*(AR(i)-AL(i))**2/A6(i) + A6(i)*R12
    … …  
    16691669  INTEGER :: i,j
    16701670  !
    1671   do j=j1,j2
    1672   do i=2,IMR
     1671  DO j=j1,j2
     1672  DO i=2,IMR
    16731673  CRX(i,J) = dtdx5(j)*(U(i,j)+U(i-1,j))
    16741674  END DO
    16751675  END DO
    16761676  !
    1677   do j=j1,j2
     1677  DO j=j1,j2
    16781678  CRX(1,J) = dtdx5(j)*(U(1,j)+U(IMR,j))
    16791679  END DO
    16801680  !
    1681   do i=1,IMR*JMR
     1681  DO i=1,IMR*JMR
    16821682  CRY(i,2) = DTDY5*(V(i,2)+V(i,1))
    16831683  END DO
    … …  
    16921692  REAL :: ph5
    16931693  JMR = JNP-1
    1694   do j=2,JNP
     1694  DO j=2,JNP
    16951695    ph5  =  -0.5*PI + (REAL(J-1)-0.5)*DP
    16961696    cose(j) = cos(ph5)
    … …  
    16991699  JEQ = (JNP+1) / 2
    17001700  IF(JMR == 2*(JMR/2) ) THEN
    1701   do j=JNP, JEQ+1, -1
     1701  DO j=JNP, JEQ+1, -1
    17021702   cose(j) =  cose(JNP+2-j)
    17031703  enddo
    … …  
    17051705  ! cell edge at equator.
    17061706   cose(JEQ+1) =  1.
    1707   do j=JNP, JEQ+2, -1
     1707  DO j=JNP, JEQ+2, -1
    17081708   cose(j) =  cose(JNP+2-j)
    17091709   enddo
    17101710  ENDIF
    17111711  !
    1712   do j=2,JMR
     1712  DO j=2,JMR
    17131713  cosp(j) = 0.5*(cose(j)+cose(j+1))
    17141714  END DO
    … …  
    17261726  !
    17271727  phi = -0.5*PI
    1728   do j=2,JNP-1
     1728  DO j=2,JNP-1
    17291729  phi  =  phi + DP
    17301730  cosp(j) = cos(phi)
    … …  
    17331733    cosp(JNP) = 0.
    17341734  !
    1735   do j=2,JNP
     1735  DO j=2,JNP
    17361736    cose(j) = 0.5*(cosp(j)+cosp(j-1))
    17371737  END DO
    17381738  !
    1739   do j=2,JNP-1
     1739  DO j=2,JNP-1
    17401740   cosp(j) = 0.5*(cose(j)+cose(j+1))
    17411741  END DO
    … …  
    17711771  !
    17721772  ! Vertical filling...
    1773   do i=1,len
     1773  DO i=1,len
    17741774  IF( Q(i,j1,1)<0.) THEN
    17751775  ip = ip + 1
    … …  
    17921792  IF(icr==0) goto 225
    17931793  !
    1794   do i=1,len
     1794  DO i=1,len
    17951795  IF( Q(I,j1,L)<0.) THEN
    17961796  !
    … …  
    18581858  REAL :: dq,dn,d0,d1,ds,d2
    18591859  icr = 0
    1860   do j=j1+1,j2-1
     1860  DO j=j1+1,j2-1
    18611861  DO i=1,IMR-1
    18621862  IF(q(i,j)<0.) THEN
    … …  
    19381938  END DO
    19391939  !
    1940   do i=1,IMR
     1940  DO i=1,IMR
    19411941  IF(q(i,j1)<0. .OR. q(i,j2)<0.) THEN
    19421942  icr = 1
    … …  
    19711971  !
    19721972  ipy = 0
    1973   do j=j1+1,j2-1
     1973  DO j=j1+1,j2-1
    19741974  DO i=1,IMR
    19751975  IF(q(i,j)<0.) THEN
    … …  
    19921992  END DO
    19931993  !
    1994   do i=1,imr
     1994  DO i=1,imr
    19951995  IF(q(i,j1)<0.) THEN
    19961996  ipy =  1
    … …  
    20062006  !
    20072007  j = j2
    2008   do i=1,imr
     2008  DO i=1,imr
    20092009  IF(q(i,j)<0.) THEN
    20102010  ipy =  1
    … …  
    20222022  IF(q(1,1)<0.) THEN
    20232023  dq = q(1,1)*cap1/REAL(IMR)*acosp(j1)
    2024   do i=1,imr
     2024  DO i=1,imr
    20252025  q(i,1) = 0.
    20262026  q(i,j1) = q(i,j1) + dq
    … …  
    20312031  IF(q(1,JNP)<0.) THEN
    20322032  dq = q(1,JNP)*cap1/REAL(IMR)*acosp(j2)
    2033   do i=1,imr
     2033  DO i=1,imr
    20342034  q(i,JNP) = 0.
    20352035  q(i,j2) = q(i,j2) + dq
    … …  
    20502050  ipx = 0
    20512051  ! Copy & swap direction for vectorization.
    2052   do i=1,imr
    2053   do j=j1,j2
     2052  DO i=1,imr
     2053  DO j=j1,j2
    20542054  qtmp(j,i) = q(i,j)
    20552055  END DO
    20562056  END DO
    20572057  !
    2058   do i=2,imr-1
    2059   do j=j1,j2
     2058  DO i=2,imr-1
     2059  DO j=j1,j2
    20602060  IF(qtmp(j,i)<0.) THEN
    20612061  ipx =  1
    … …  
    20752075  !
    20762076  i=1
    2077   do j=j1,j2
     2077  DO j=j1,j2
    20782078  IF(qtmp(j,i)<0.) THEN
    20792079  ipx =  1
    … …  
    20922092  END DO
    20932093  i=IMR
    2094   do j=j1,j2
     2094  DO j=j1,j2
    20952095  IF(qtmp(j,i)<0.) THEN
    20962096  ipx =  1
    … …  
    21102110  !
    21112111  IF(ipx/=0) THEN
    2112   do j=j1,j2
    2113   do i=1,imr
     2112  DO j=j1,j2
     2113  DO i=1,imr
    21142114  q(i,j) = qtmp(j,i)
    21152115  END DO
    … …  
    21322132  INTEGER :: IC,k,i
    21332133  !
    2134   do IC = 1, nc
    2135   !
    2136   do k=1,km
    2137   do i=1,im
     2134  DO IC = 1, nc
     2135  !
     2136  DO k=1,km
     2137  DO i=1,im
    21382138  qtmp(i,k) = q(i,km+1-k,IC)
    21392139  END DO
    21402140  END DO
    21412141  !
    2142   do i=1,im*km
     2142  DO i=1,im*km
    21432143  q(i,1,IC) = qtmp(i,1)
    21442144  END DO

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/prather.f90

    r5136 r5158  
    8181     PRINT*,'SCHEMA PRATHER'
    8282     first=.FALSE.
    83      do i=2,iip1
     83     DO i=2,iip1
    8484        coslon(i)=cos(rlonv(i))
    8585        sinlon(i)=sin(rlonv(i))
    … …  
    144144
    145145  !-----------------------------------------------------------
    146    do indice =1,nt
     146   DO indice =1,nt
    147147   CALL advxp( limit,0.5*dt,pbaru,sm,s0,sx,sy,sz &
    148148         ,sxx,sxy,sxz,syy,syz,szz,1 )
    149149    END DO
    150     do l=1,llm
    151     do i=1,iip1
     150    DO l=1,llm
     151    DO i=1,iip1
    152152    sy(i,1,l)=0.
    153153    sy(i,jjp1,l)=0.
    … …  
    160160
    161161  !---------------------------------------------------------
    162    do j=1,jjp1
    163       do i=1,iip1
     162   DO j=1,jjp1
     163      DO i=1,iip1
    164164         sz(i,j,1)=0.
    165165         sz(i,j,llm)=0.
    … …  
    174174   CALL advzp( limit,dt*nt,w,sm,s0,sx,sy,sz &
    175175         ,sxx,sxy,sxz,syy,syz,szz,1 )
    176     do l=1,llm
    177     do i=1,iip1
     176    DO l=1,llm
     177    DO i=1,iip1
    178178    sy(i,1,l)=0.
    179179    sy(i,jjp1,l)=0.
    … …  
    201201    ENDDO
    202202   ENDDO
    203    do indice=1,nt
     203   DO indice=1,nt
    204204   CALL advxp( limit,0.5*dt,pbaru,sm,s0,sx,sy,sz &
    205205         ,sxx,sxy,sxz,syy,syz,szz,1 )
    … …  
    242242     dqzpn=ssum(iim,sz(1,1,l),1)/masn
    243243     dqzps=ssum(iim,sz(1,jjp1,l),1)/mass
    244      do i=1,iip1
     244     DO i=1,iip1
    245245      q( i,1,llm+1-l,3)=dqzpn
    246246      q( i,jjp1,llm+1-l,3)=dqzps
    … …  
    256256       dyn2=0.
    257257       dys2=0.
    258     do i=1,iim
     258    DO i=1,iim
    259259    zz=s0(i,2,l)/sm(i,2,l)-q(i,1,llm+1-l,0)
    260260    dyn1=dyn1+sinlondlon(i)*zz
    … …  
    264264    dys2=dys2+coslondlon(i)*zz
    265265    enddo
    266      do i=1,iim
     266     DO i=1,iim
    267267     q(i,1,llm+1-l,2)= &
    268268           (sinlon(i)*dyn1+coslon(i)*dyn2)/2.
    … …  
    276276  q(iip1,1,llm+1-l,0)=q(1,1,llm+1-l,0)
    277277  q(iip1,jjp1,llm+1-l,0)=q(1,jjp1,llm+1-l,0)
    278   do i=1,iim
     278  DO i=1,iim
    279279  sxn(i)=q(i+1,1,llm+1-l,0)-q(i,1,llm+1-l,0)
    280280  sxs(i)=q(i+1,jjp1,llm+1-l,0)-q(i,jjp1,llm+1-l,0)
    … …  
    282282  sxn(iip1)=sxn(1)
    283283  sxs(iip1)=sxs(1)
    284   do i=1,iim
     284  DO i=1,iim
    285285  q(i+1,1,llm+1-l,1)=0.25*(sxn(i)+sxn(i+1))
    286286  q(i+1,jjp1,llm+1-l,1)=0.25*(sxs(i)+sxs(i+1))
    … …  
    290290        q(iip1,jjp1,llm+1-l,1)
    291291    enddo
    292      do l=1,llm
    293        do i=1,iim
     292     DO l=1,llm
     293       DO i=1,iim
    294294        q( i,1,llm+1-l,4)=0.
    295295        q( i,jjp1,llm+1-l,4)=0.
    … …  
    310310  !
    311311  !   bouclage en longitude
    312   do l=1,llm
    313   do j=1,jjp1
     312  DO l=1,llm
     313  DO j=1,jjp1
    314314  q(iip1,j,l,0)=q(1,j,l,0)
    315315  q(iip1,j,llm+1-l,0)=q(1,j,llm+1-l,0)
    … …  
    336336           q(i,j-1,l,2)
    337337     PRINT*,'SZ(',i,j,l,')=',q(i,j,l,3)
    338   !                  PRINT*,' PBL EN SORTIE D'' ADVZP'
     338  !                 PRINT*,' PBL EN SORTIE D'' ADVZP'
    339339                 q(i,j,l,0)=0.
    340340               ! STOP
    … …  
    342342       ENDDO
    343343     ENDDO
    344      do j=1,jjp1,jjm
    345      do i=1,iip1
     344     DO j=1,jjp1,jjm
     345     DO i=1,iip1
    346346           IF (q(i,j,l,0)<0.)  THEN
    347347           PRINT*,'------------ BIP 2-----------'

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/test_period.f90

    r5117 r5158  
    4242     ENDDO
    4343
    44      do ij=1,iim
     44     DO ij=1,iim
    4545      IF (teta(ij,l)/=teta(1,l) &
    4646            .OR.teta(ip1jm+ij,l)/=teta(ip1jm+1,l) ) THEN
    … …  
    9898      ENDIF
    9999     ENDDO
    100      do ij=1,iim
     100     DO ij=1,iim
    101101      IF (p(ij,l)/=p(1,l) &
    102102            .OR.p(ip1jm+ij,l)/=p(ip1jm+1,l) ) THEN

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/traceurpole.f90

    r5136 r5158  
    3030  sommemasses = 0
    3131  sommemqs = 0
    32   do l = 1, llm
    33     do i = 1, iip1
     32  DO l = 1, llm
     33    DO i = 1, iip1
    3434      sommemasses(l) = sommemasses(l) + masse(i, jjp1, l)
    3535      sommemqs(l) = sommemqs(l) + masse(i, jjp1, l) * q(i, jjp1, l)
    … …  
    4141  sommemassen = 0
    4242  sommemqn = 0
    43   do l = 1, llm
    44     do i = 1, iip1
     43  DO l = 1, llm
     44    DO i = 1, iip1
    4545      sommemassen(l) = sommemassen(l) + masse(i, 1, l)
    4646      sommemqn(l) = sommemqn(l) + masse(i, 1, l) * q(i, 1, l)
    … …  
    5050
    5151  ! On force le traceur à prendre cette valeur aux pôles
    52   do l = 1, llm
    53     do i = 1, iip1
     52  DO l = 1, llm
     53    DO i = 1, iip1
    5454      q(i, 1, l) = qpolen(l)
    5555      q(i, jjp1, l) = qpoles(l)

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/write_grads_dyn.h

    r5117 r5158  
    2323string10='teta'
    2424CALL wrgrads(1,llm,teta,string10,string10)
    25 do iq=1,nqtot
     25DO iq=1,nqtot
    2626   string10='q'
    2727   WRITE(string10(2:2),'(i1)') iq

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/writedynav.F90

    r5136 r5158  
    8888  !  Temperature moyennee
    8989
    90   do ii = 1, ijp1llm
     90  DO ii = 1, ijp1llm
    9191    tm(ii) = teta(ii) * ppk(ii) / cpp
    9292  enddo
Note: See TracChangeset for help on using the changeset viewer.