Ignore:
Timestamp:
2017-09-22T16:55:24+02:00 (3 years ago)
Author:
clem
Message:

almost useless commits

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/2017/dev_r8183_ICEMODEL/NEMOGCM/NEMO/LIM_SRC_3/icethd_do.F90

    r8534 r8559  
    8080      INTEGER  ::   ji,jj,jk,jl      ! dummy loop indices 
    8181      INTEGER  ::   iter     !   -       - 
    82       REAL(wp) ::   ztmelts, zdv, zfrazb, zweight, zde                          ! local scalars 
     82      REAL(wp) ::   ztmelts, zfrazb, zweight, zde                          ! local scalars 
    8383      REAL(wp) ::   zgamafr, zvfrx, zvgx, ztaux, ztwogp, zf                     !   -      - 
    8484      REAL(wp) ::   ztenagm, zvfry, zvgy, ztauy, zvrel2, zfp, zsqcd , zhicrit   !   -      - 
     
    102102      REAL(wp), DIMENSION(jpij) ::   zdv_res     ! residual volume in case of excessive heat budget 
    103103      REAL(wp), DIMENSION(jpij) ::   zda_res     ! residual area in case of excessive heat budget 
    104       REAL(wp), DIMENSION(jpij) ::   zat_i_1d    ! total ice fraction     
    105104      REAL(wp), DIMENSION(jpij) ::   zv_frazb    ! accretion of frazil ice at the ice bottom 
    106105      REAL(wp), DIMENSION(jpij) ::   zvrel_1d    ! relative ice / frazil velocity (1D vector) 
     
    108107      REAL(wp), DIMENSION(jpij,jpl) ::   zv_b      ! old volume of ice in category jl 
    109108      REAL(wp), DIMENSION(jpij,jpl) ::   za_b      ! old area of ice in category jl 
    110       REAL(wp), DIMENSION(jpij,jpl) ::   za_i_1d   ! 1-D version of a_i 
    111       REAL(wp), DIMENSION(jpij,jpl) ::   zv_i_1d   ! 1-D version of v_i 
    112       REAL(wp), DIMENSION(jpij,jpl) ::   zsmv_i_1d ! 1-D version of smv_i 
    113  
    114       REAL(wp), DIMENSION(jpij,nlay_i,jpl) ::   ze_i_1d !: 1-D version of e_i 
     109 
     110      REAL(wp), DIMENSION(jpij,nlay_i,jpl) ::   ze_i_2d !: 1-D version of e_i 
    115111 
    116112      REAL(wp), DIMENSION(jpi,jpj) ::   zvrel     ! relative ice / frazil velocity 
     
    243239      IF ( nidx > 0 ) THEN 
    244240 
    245          CALL tab_2d_1d( nidx, idxice(1:nidx), zat_i_1d  (1:nidx)     , at_i           ) 
     241         CALL tab_2d_1d( nidx, idxice(1:nidx), at_i_1d (1:nidx)      , at_i         ) 
     242         CALL tab_3d_2d( nidx, idxice(1:nidx), a_i_2d  (1:nidx,1:jpl), a_i  (:,:,:) ) 
     243         CALL tab_3d_2d( nidx, idxice(1:nidx), v_i_2d  (1:nidx,1:jpl), v_i  (:,:,:) ) 
     244         CALL tab_3d_2d( nidx, idxice(1:nidx), smv_i_2d(1:nidx,1:jpl), smv_i(:,:,:) ) 
    246245         DO jl = 1, jpl 
    247             CALL tab_2d_1d( nidx, idxice(1:nidx), za_i_1d  (1:nidx,jl), a_i  (:,:,jl)  ) 
    248             CALL tab_2d_1d( nidx, idxice(1:nidx), zv_i_1d  (1:nidx,jl), v_i  (:,:,jl)  ) 
    249             CALL tab_2d_1d( nidx, idxice(1:nidx), zsmv_i_1d(1:nidx,jl), smv_i(:,:,jl)  ) 
    250246            DO jk = 1, nlay_i 
    251                CALL tab_2d_1d( nidx, idxice(1:nidx), ze_i_1d(1:nidx,jk,jl), e_i(:,:,jk,jl)   ) 
    252             END DO 
    253          END DO 
    254  
    255          CALL tab_2d_1d( nidx, idxice(1:nidx), qlead_1d  (1:nidx)     , qlead       ) 
    256          CALL tab_2d_1d( nidx, idxice(1:nidx), t_bo_1d   (1:nidx)     , t_bo        ) 
    257          CALL tab_2d_1d( nidx, idxice(1:nidx), sfx_opw_1d(1:nidx)     , sfx_opw     ) 
    258          CALL tab_2d_1d( nidx, idxice(1:nidx), wfx_opw_1d(1:nidx)     , wfx_opw     ) 
    259          CALL tab_2d_1d( nidx, idxice(1:nidx), hicol_1d  (1:nidx)     , hicol       ) 
    260          CALL tab_2d_1d( nidx, idxice(1:nidx), zvrel_1d  (1:nidx)     , zvrel       ) 
    261  
    262          CALL tab_2d_1d( nidx, idxice(1:nidx), hfx_thd_1d(1:nidx)     , hfx_thd     ) 
    263          CALL tab_2d_1d( nidx, idxice(1:nidx), hfx_opw_1d(1:nidx)     , hfx_opw     ) 
    264          CALL tab_2d_1d( nidx, idxice(1:nidx), rn_amax_1d(1:nidx)     , rn_amax_2d  ) 
    265          CALL tab_2d_1d( nidx, idxice(1:nidx), sss_1d    (1:nidx)     , sss_m       ) 
     247               CALL tab_2d_1d( nidx, idxice(1:nidx), ze_i_2d(1:nidx,jk,jl), e_i(:,:,jk,jl) ) 
     248            END DO 
     249         END DO 
     250         CALL tab_2d_1d( nidx, idxice(1:nidx), qlead_1d  (1:nidx) , qlead       ) 
     251         CALL tab_2d_1d( nidx, idxice(1:nidx), t_bo_1d   (1:nidx) , t_bo        ) 
     252         CALL tab_2d_1d( nidx, idxice(1:nidx), sfx_opw_1d(1:nidx) , sfx_opw     ) 
     253         CALL tab_2d_1d( nidx, idxice(1:nidx), wfx_opw_1d(1:nidx) , wfx_opw     ) 
     254         CALL tab_2d_1d( nidx, idxice(1:nidx), zh_newice (1:nidx) , hicol       ) 
     255         CALL tab_2d_1d( nidx, idxice(1:nidx), zvrel_1d  (1:nidx) , zvrel       ) 
     256 
     257         CALL tab_2d_1d( nidx, idxice(1:nidx), hfx_thd_1d(1:nidx) , hfx_thd     ) 
     258         CALL tab_2d_1d( nidx, idxice(1:nidx), hfx_opw_1d(1:nidx) , hfx_opw     ) 
     259         CALL tab_2d_1d( nidx, idxice(1:nidx), rn_amax_1d(1:nidx) , rn_amax_2d  ) 
     260         CALL tab_2d_1d( nidx, idxice(1:nidx), sss_1d    (1:nidx) , sss_m       ) 
    266261 
    267262         !------------------------------------------------------------------------------| 
     
    269264         !------------------------------------------------------------------------------| 
    270265         DO jl = 1, jpl 
    271             DO jk = 1, nlay_i 
    272                DO ji = 1, nidx 
    273                   IF( zv_i_1d(ji,jl) > 0._wp )   ze_i_1d(ji,jk,jl) = ze_i_1d(ji,jk,jl) / zv_i_1d(ji,jl) * REAL( nlay_i ) 
    274                END DO 
     266            DO jk = 1, nlay_i                
     267               WHERE( v_i_2d(1:nidx,jl) > 0._wp ) 
     268                  ze_i_2d(1:nidx,jk,jl) = ze_i_2d(1:nidx,jk,jl) / v_i_2d(1:nidx,jl) * REAL( nlay_i ) 
     269               ELSEWHERE 
     270                  ze_i_2d(1:nidx,jk,jl) = 0._wp 
     271               END WHERE 
    275272            END DO 
    276273         END DO 
     
    282279         ! Keep old ice areas and volume in memory 
    283280         !----------------------------------------- 
    284          zv_b(1:nidx,:) = zv_i_1d(1:nidx,:)  
    285          za_b(1:nidx,:) = za_i_1d(1:nidx,:) 
    286  
    287          !---------------------- 
    288          ! Thickness of new ice 
    289          !---------------------- 
    290          zh_newice(1:nidx) = hicol_1d(1:nidx) 
     281         zv_b(1:nidx,:) = v_i_2d(1:nidx,:)  
     282         za_b(1:nidx,:) = a_i_2d(1:nidx,:) 
    291283 
    292284         !---------------------- 
     
    309301         ! We assume that new ice is formed at the seawater freezing point 
    310302         DO ji = 1, nidx 
    311             ztmelts       = - tmut * zs_newice(ji) + rt0                  ! Melting point (K) 
    312             ze_newice(ji) =   rhoic * (  cpic * ( ztmelts - t_bo_1d(ji) )                                         & 
    313                &                       + lfus * ( 1.0 - ( ztmelts - rt0 ) / MIN( t_bo_1d(ji) - rt0, -epsi10 ) )   & 
    314                &                       - rcp  *         ( ztmelts - rt0 ) ) 
     303            ztmelts       = - tmut * zs_newice(ji)                  ! Melting point (C) 
     304            ze_newice(ji) =   rhoic * (  cpic * ( ztmelts - ( t_bo_1d(ji) - rt0 ) )                     & 
     305               &                       + lfus * ( 1.0 - ztmelts / MIN( t_bo_1d(ji) - rt0, -epsi10 ) )   & 
     306               &                       - rcp  *         ztmelts ) 
    315307         END DO 
    316308 
     
    318310         ! Age of new ice 
    319311         !---------------- 
    320          DO ji = 1, nidx 
    321             zo_newice(ji) = 0._wp 
    322          END DO 
     312         zo_newice(1:nidx) = 0._wp 
    323313 
    324314         !------------------- 
     
    350340         END DO 
    351341          
    352          zv_frazb(:) = 0._wp 
     342         zv_frazb(1:nidx) = 0._wp 
    353343         IF( ln_frazil ) THEN 
    354344            ! A fraction zfrazb of frazil ice is accreted at the ice bottom 
    355345            DO ji = 1, nidx 
    356                rswitch       = 1._wp - MAX( 0._wp, SIGN( 1._wp , - zat_i_1d(ji) ) ) 
     346               rswitch       = 1._wp - MAX( 0._wp, SIGN( 1._wp , - at_i_1d(ji) ) ) 
    357347               zfrazb        = rswitch * ( TANH( rn_Cfraz * ( zvrel_1d(ji) - rn_vfraz ) ) + 1.0 ) * 0.5 * rn_maxfraz 
    358348               zv_frazb(ji)  =         zfrazb   * zv_newice(ji) 
     
    378368         ! we keep the excessive volume in memory and attribute it later to bottom accretion 
    379369         DO ji = 1, nidx 
    380             IF ( za_newice(ji) >  ( rn_amax_1d(ji) - zat_i_1d(ji) ) ) THEN 
    381                zda_res(ji)   = za_newice(ji) - ( rn_amax_1d(ji) - zat_i_1d(ji) ) 
     370            IF ( za_newice(ji) >  ( rn_amax_1d(ji) - at_i_1d(ji) ) ) THEN 
     371               zda_res(ji)   = za_newice(ji) - ( rn_amax_1d(ji) - at_i_1d(ji) ) 
    382372               zdv_res(ji)   = zda_res  (ji) * zh_newice(ji)  
    383373               za_newice(ji) = za_newice(ji) - zda_res  (ji) 
     
    390380 
    391381         ! find which category to fill 
    392          zat_i_1d(:) = 0._wp 
    393382         DO jl = 1, jpl 
    394383            DO ji = 1, nidx 
    395384               IF( zh_newice(ji) > hi_max(jl-1) .AND. zh_newice(ji) <= hi_max(jl) ) THEN 
    396                   za_i_1d (ji,jl) = za_i_1d (ji,jl) + za_newice(ji) 
    397                   zv_i_1d (ji,jl) = zv_i_1d (ji,jl) + zv_newice(ji) 
    398                   jcat    (ji)    = jl 
     385                  a_i_2d(ji,jl) = a_i_2d(ji,jl) + za_newice(ji) 
     386                  v_i_2d(ji,jl) = v_i_2d(ji,jl) + zv_newice(ji) 
     387                  jcat(ji) = jl 
    399388               ENDIF 
    400                zat_i_1d(ji) = zat_i_1d(ji) + za_i_1d  (ji,jl) 
    401             END DO 
    402          END DO 
     389            END DO 
     390         END DO 
     391         at_i_1d(1:nidx) = SUM( a_i_2d(1:nidx,:), dim=2 ) 
    403392 
    404393         ! Heat content 
     
    411400            DO ji = 1, nidx 
    412401               jl = jcat(ji) 
    413                rswitch = MAX( 0._wp, SIGN( 1._wp , zv_i_1d(ji,jl) - epsi20 ) ) 
    414                ze_i_1d(ji,jk,jl) = zswinew(ji)   *   ze_newice(ji) +                                                    & 
    415                   &        ( 1.0 - zswinew(ji) ) * ( ze_newice(ji) * zv_newice(ji) + ze_i_1d(ji,jk,jl) * zv_b(ji,jl) )  & 
    416                   &        * rswitch / MAX( zv_i_1d(ji,jl), epsi20 ) 
     402               rswitch = MAX( 0._wp, SIGN( 1._wp , v_i_2d(ji,jl) - epsi20 ) ) 
     403               ze_i_2d(ji,jk,jl) = zswinew(ji)   *   ze_newice(ji) +                                                    & 
     404                  &        ( 1.0 - zswinew(ji) ) * ( ze_newice(ji) * zv_newice(ji) + ze_i_2d(ji,jk,jl) * zv_b(ji,jl) )  & 
     405                  &        * rswitch / MAX( v_i_2d(ji,jl), epsi20 ) 
    417406            END DO 
    418407         END DO 
     
    428417            DO jk = 1, nlay_i 
    429418               DO ji = 1, nidx 
    430                   h_i_old (ji,jk) = zv_i_1d(ji,jl) * r1_nlay_i 
    431                   eh_i_old(ji,jk) = ze_i_1d(ji,jk,jl) * h_i_old(ji,jk) 
     419                  h_i_old (ji,jk) = v_i_2d(ji,jl) * r1_nlay_i 
     420                  eh_i_old(ji,jk) = ze_i_2d(ji,jk,jl) * h_i_old(ji,jk) 
    432421               END DO 
    433422            END DO 
     
    435424            ! new volumes including lateral/bottom accretion + residual 
    436425            DO ji = 1, nidx 
    437                rswitch        = MAX( 0._wp, SIGN( 1._wp , zat_i_1d(ji) - epsi20 ) ) 
    438                zv_newfra      = rswitch * ( zdv_res(ji) + zv_frazb(ji) ) * za_i_1d(ji,jl) / MAX( zat_i_1d(ji) , epsi20 ) 
    439                za_i_1d(ji,jl) = rswitch * za_i_1d(ji,jl)                
    440                zv_i_1d(ji,jl) = zv_i_1d(ji,jl) + zv_newfra 
     426               rswitch        = MAX( 0._wp, SIGN( 1._wp , at_i_1d(ji) - epsi20 ) ) 
     427               zv_newfra     = rswitch * ( zdv_res(ji) + zv_frazb(ji) ) * a_i_2d(ji,jl) / MAX( at_i_1d(ji) , epsi20 ) 
     428               a_i_2d(ji,jl) = rswitch * a_i_2d(ji,jl)                
     429               v_i_2d(ji,jl) = v_i_2d(ji,jl) + zv_newfra 
    441430               ! for remapping 
    442431               h_i_old (ji,nlay_i+1) = zv_newfra 
     
    444433            ENDDO 
    445434            ! --- Ice enthalpy remapping --- ! 
    446             CALL ice_thd_ent( ze_i_1d(1:nidx,:,jl) )  
     435            CALL ice_thd_ent( ze_i_2d(1:nidx,:,jl) )  
    447436         ENDDO 
    448437 
     
    452441         DO jl = 1, jpl 
    453442            DO ji = 1, nidx 
    454                zdv   = zv_i_1d(ji,jl) - zv_b(ji,jl) 
    455                zsmv_i_1d(ji,jl) = zsmv_i_1d(ji,jl) + zdv * zs_newice(ji) 
     443               smv_i_2d(ji,jl) = smv_i_2d(ji,jl) + zs_newice(ji) * ( v_i_2d(ji,jl) - zv_b(ji,jl) ) 
    456444            END DO 
    457445         END DO 
     
    462450         DO jl = 1, jpl 
    463451            DO jk = 1, nlay_i 
    464                DO ji = 1, nidx 
    465                   ze_i_1d(ji,jk,jl) = ze_i_1d(ji,jk,jl) * zv_i_1d(ji,jl) * r1_nlay_i  
    466                END DO 
     452               ze_i_2d(1:nidx,jk,jl) = ze_i_2d(1:nidx,jk,jl) * v_i_2d(1:nidx,jl) * r1_nlay_i  
    467453            END DO 
    468454         END DO 
     
    470456         ! 7) Change 2D vectors to 1D vectors  
    471457         !------------------------------------------------------------------------------! 
    472          DO jl = 1, jpl 
    473             CALL tab_1d_2d( nidx, idxice(1:nidx), za_i_1d (1:nidx,jl), a_i (:,:,jl) ) 
    474             CALL tab_1d_2d( nidx, idxice(1:nidx), zv_i_1d (1:nidx,jl), v_i (:,:,jl) ) 
    475             CALL tab_1d_2d( nidx, idxice(1:nidx), zsmv_i_1d(1:nidx,jl), smv_i (:,:,jl)   ) 
     458         CALL tab_2d_3d( nidx, idxice(1:nidx), a_i_2d  (1:nidx,1:jpl), a_i  (:,:,:) ) 
     459         CALL tab_2d_3d( nidx, idxice(1:nidx), v_i_2d  (1:nidx,1:jpl), v_i  (:,:,:) ) 
     460         CALL tab_2d_3d( nidx, idxice(1:nidx), smv_i_2d(1:nidx,1:jpl), smv_i(:,:,:) ) 
     461          DO jl = 1, jpl 
    476462            DO jk = 1, nlay_i 
    477                CALL tab_1d_2d( nidx, idxice(1:nidx), ze_i_1d(1:nidx,jk,jl), e_i(:,:,jk,jl) ) 
    478             END DO 
    479          END DO 
    480          CALL tab_1d_2d( nidx, idxice(1:nidx), sfx_opw_1d(1:nidx), sfx_opw  ) 
    481          CALL tab_1d_2d( nidx, idxice(1:nidx), wfx_opw_1d(1:nidx), wfx_opw  ) 
    482          CALL tab_1d_2d( nidx, idxice(1:nidx), hfx_thd_1d(1:nidx), hfx_thd  ) 
    483          CALL tab_1d_2d( nidx, idxice(1:nidx), hfx_opw_1d(1:nidx), hfx_opw  ) 
     463               CALL tab_1d_2d( nidx, idxice(1:nidx), ze_i_2d(1:nidx,jk,jl), e_i(:,:,jk,jl) ) 
     464            END DO 
     465         END DO 
     466         CALL tab_1d_2d( nidx, idxice(1:nidx), sfx_opw_1d(1:nidx), sfx_opw ) 
     467         CALL tab_1d_2d( nidx, idxice(1:nidx), wfx_opw_1d(1:nidx), wfx_opw ) 
     468         CALL tab_1d_2d( nidx, idxice(1:nidx), hfx_thd_1d(1:nidx), hfx_thd ) 
     469         CALL tab_1d_2d( nidx, idxice(1:nidx), hfx_opw_1d(1:nidx), hfx_opw ) 
    484470         ! 
    485471      ENDIF ! nidx > 0 
Note: See TracChangeset for help on using the changeset viewer.