Ignore:
Timestamp:
2011-03-30T17:58:35+02:00 (10 years ago)
Author:
rblod
Message:

First attempt to put dynamic allocation on the trunk

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/NEMOGCM/NEMO/LIM_SRC_3/limthd_sal.F90

    r2528 r2715  
    66   !! History :   -   ! 2003-05 (M. Vancoppenolle) UCL-ASTR first coding for LIM3-1D 
    77   !!            3.0  ! 2005-12 (M. Vancoppenolle) adapted to the 3-D version 
     8   !!            4.0  ! 2011-02 (G. Madec) dynamical allocation 
    89   !!--------------------------------------------------------------------- 
    910#if defined key_lim3 
     
    1617   USE phycst           ! physical constants (ocean directory) 
    1718   USE sbc_oce          ! Surface boundary condition: ocean fields 
    18    USE ice              ! LIM: sea-ice variables 
    19    USE par_ice          ! LIM: sea-ice parameters 
    20    USE thd_ice          ! LIM: sea-ice thermodynamics 
    21    USE limvar           ! LIM: sea-ice variables 
     19   USE ice              ! LIM variables 
     20   USE par_ice          ! LIM parameters 
     21   USE thd_ice          ! LIM thermodynamics 
     22   USE limvar           ! LIM variables 
     23   USE wrk_nemo         ! workspace manager 
    2224   USE in_out_manager   ! I/O manager 
     25   USE lib_mpp         ! MPP library 
    2326 
    2427   IMPLICIT NONE 
     
    2932 
    3033   !!---------------------------------------------------------------------- 
    31    !! NEMO/LIM3 3.3 , UCL - NEMO Consortium (2010) 
     34   !! NEMO/LIM3 4.0 , UCL - NEMO Consortium (2011) 
    3235   !! $Id$ 
    3336   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
     
    5154      INTEGER  ::   ji, jk     ! dummy loop indices  
    5255      INTEGER  ::   zji, zjj   ! local integers 
    53       REAL(wp) ::   zsold, zeps, iflush, iaccrbo, igravdr, isnowic, i_ice_switch,  ztmelts   ! local scalars 
     56      REAL(wp) ::   zsold, iflush, iaccrbo, igravdr, isnowic, i_ice_switch,  ztmelts   ! local scalars 
    5457      REAL(wp) ::   zaaa, zbbb, zccc, zdiscrim   ! local scalars 
    55       REAL(wp), DIMENSION(jpij) ::   ze_init, zhiold, zsiold   ! 1D workspace 
     58      ! 
     59      REAL(wp), POINTER, DIMENSION(:) ::   ze_init, zhiold, zsiold 
    5660      !!--------------------------------------------------------------------- 
    5761 
    58       zeps=1.0e-06_wp 
     62      IF(  wrk_in_use(1, 1,2,3)  ) THEN 
     63         CALL ctl_stop('lim_thd_dh : requestead workspace arrays unavailable.')   ;   RETURN 
     64      END IF 
     65      ! Set-up pointers to sub-arrays of workspace arrays 
     66      ze_init =>  wrk_1d_1 (1:jpij) 
     67      zhiold  =>  wrk_1d_2 (1:jpij) 
     68      zsiold  =>  wrk_1d_3 (1:jpij) 
    5969 
    6070      !------------------------------------------------------------------------------| 
    6171      ! 1) Constant salinity, constant in time                                       | 
    6272      !------------------------------------------------------------------------------| 
    63  
     73!!gm comment: if num_sal = 1 s_i_b and sm_i_b can be set to bulk_sal one for all in the initialisation phase !! 
    6474      IF( num_sal == 1 ) THEN 
     75         ! 
    6576         DO jk = 1, nlay_i 
    6677            DO ji = kideb, kiut 
     
    7990      !------------------------------------------------------------------------------| 
    8091 
    81       IF ( ( num_sal .EQ. 2 ) .OR. ( num_sal .EQ. 4 ) ) THEN 
    82  
    83          !         WRITE(numout,*) 
    84          !         WRITE(numout,*) 'lim_thd_sal : Ice salinity computation module ', & 
    85          !         num_sal 
    86          !         WRITE(numout,*) '~~~~~~~~~~~' 
    87          !         WRITE(numout,*) 
     92      IF(  num_sal == 2  .OR.  num_sal == 4  ) THEN 
    8893 
    8994         !--------------------------------- 
     
    9196         !--------------------------------- 
    9297         DO ji = kideb, kiut 
    93             zhiold(ji)   =  ht_i_b(ji) - dh_i_bott(ji) - dh_snowice(ji) -     & 
    94                dh_i_surf(ji) 
    95          END DO ! ji 
     98            zhiold(ji) = ht_i_b(ji) - dh_i_bott(ji) - dh_snowice(ji) - dh_i_surf(ji) 
     99         END DO 
    96100 
    97101         !--------------------- 
    98102         ! Global heat content 
    99103         !--------------------- 
    100  
    101          ze_init(:)  =  0.0 
     104         ze_init(:)  =  0._wp 
    102105         DO jk = 1, nlay_i 
    103106            DO ji = kideb, kiut 
    104107               ze_init(ji) = ze_init(ji) + q_i_b(ji,jk) * ht_i_b(ji) / nlay_i 
    105             END DO ! ji 
    106          END DO ! jk 
    107  
    108          DO ji = kideb, kiut 
    109  
    110             !---------- 
     108            END DO 
     109         END DO 
     110 
     111         DO ji = kideb, kiut 
     112            ! 
    111113            ! Switches  
    112114            !---------- 
    113  
    114             ! iflush  : 1 if summer  
    115             iflush       =  MAX( 0.0 , SIGN ( 1.0 , t_su_b(ji) - rtt ) )  
    116             ! igravdr : 1 if t_su lt t_bo 
    117             igravdr      =  MAX( 0.0 , SIGN ( 1.0 , t_bo_b(ji) - t_su_b(ji) ) ) 
    118             ! iaccrbo : 1 if bottom accretion 
    119             iaccrbo      =  MAX( 0.0 , SIGN ( 1.0 , dh_i_bott(ji) ) ) 
    120             ! isnowic : 1 if snow ice formation 
    121             i_ice_switch = 1.0 - MAX ( 0.0 , SIGN ( 1.0 , - ht_i_b(ji) + 1.0e-2 ) ) 
    122             isnowic      = 1.0 - MAX ( 0.0 , SIGN ( 1.0 , - dh_snowice(ji) ) ) * i_ice_switch 
     115            iflush       =         MAX( 0._wp , SIGN( 1.0 , t_su_b(ji) - rtt )        )    ! =1 if summer  
     116            igravdr      =         MAX( 0._wp , SIGN( 1.0 , t_bo_b(ji) - t_su_b(ji) ) )    ! =1 if t_su < t_bo 
     117            iaccrbo      =         MAX( 0._wp , SIGN( 1.0 , dh_i_bott(ji) )           )    ! =1 if bottom accretion 
     118            i_ice_switch = 1._wp - MAX ( 0._wp , SIGN( 1._wp , - ht_i_b(ji) + 1.e-2 ) ) 
     119            isnowic      = 1._wp - MAX ( 0._wp , SIGN( 1._wp , - dh_snowice(ji) ) ) * i_ice_switch   ! =1 if snow ice formation 
    123120 
    124121            !--------------------- 
    125122            ! Salinity tendencies 
    126123            !--------------------- 
    127  
    128             ! drainage by gravity drainage 
     124            !                                   ! drainage by gravity drainage 
    129125            dsm_i_gd_1d(ji) = - igravdr * MAX( sm_i_b(ji) - sal_G , 0._wp ) / time_G * rdt_ice  
    130  
    131             ! drainage by flushing   
    132             dsm_i_fl_1d(ji)  = - iflush * MAX( sm_i_b(ji) - sal_F , 0._wp ) / time_F * rdt_ice 
     126            !                                   ! drainage by flushing   
     127            dsm_i_fl_1d(ji) = - iflush * MAX( sm_i_b(ji) - sal_F , 0._wp ) / time_F * rdt_ice 
    133128 
    134129            !----------------- 
    135130            ! Update salinity    
    136131            !----------------- 
    137  
    138132            ! only drainage terms ( gravity drainage and flushing ) 
    139             ! snow ice / bottom sources are added in lim_thd_ent 
    140             ! to conserve energy 
     133            ! snow ice / bottom sources are added in lim_thd_ent to conserve energy 
    141134            zsiold(ji) = sm_i_b(ji) 
    142135            sm_i_b(ji) = sm_i_b(ji) + dsm_i_fl_1d(ji) + dsm_i_gd_1d(ji) 
    143136 
    144             ! if no ice, salinity eq 0.1 
     137            ! if no ice, salinity = 0.1 
    145138            i_ice_switch = 1._wp - MAX ( 0._wp, SIGN( 1._wp , - ht_i_b(ji) ) ) 
    146             sm_i_b(ji)   = i_ice_switch*sm_i_b(ji) + s_i_min * ( 1._wp - i_ice_switch ) 
     139            sm_i_b(ji)   = i_ice_switch * sm_i_b(ji) + s_i_min * ( 1._wp - i_ice_switch ) 
    147140         END DO ! ji 
    148141 
     
    155148 
    156149         DO ji = kideb, kiut 
     150!!gm useless 
    157151            ! iflush  : 1 if summer  
    158152            iflush  =  MAX( 0._wp , SIGN ( 1._wp , t_su_b(ji) - rtt ) )  
     
    161155            ! iaccrbo : 1 if bottom accretion 
    162156            iaccrbo =  MAX( 0._wp , SIGN ( 1._wp , dh_i_bott(ji) ) ) 
     157!!gm end useless 
    163158            ! 
    164159            fhbri_1d(ji) = 0._wp 
     
    186181               zbbb         =  ( rcp - cpic ) * ( ztmelts - rtt ) + q_i_b(ji,jk) / rhoic - lfus 
    187182               zccc         =  lfus * ( ztmelts - rtt ) 
    188                zdiscrim     =  SQRT( MAX(zbbb*zbbb - 4.0*zaaa*zccc,0.0) ) 
     183               zdiscrim     =  SQRT(  MAX( zbbb*zbbb - 4.0*zaaa*zccc, 0._wp ) ) 
    189184               t_i_b(ji,jk) =  rtt - ( zbbb + zdiscrim ) / ( 2.0 *zaaa ) 
    190             END DO !ji 
    191          END DO !jk 
     185            END DO 
     186         END DO 
    192187         ! 
    193188      ENDIF ! num_sal .EQ. 2 
     
    197192      !------------------------------------------------------------------------------| 
    198193 
    199       IF( num_sal .EQ. 3 ) THEN 
    200  
    201          WRITE(numout,*) 
    202          WRITE(numout,*) 'lim_thd_sal : Ice salinity computation module ', & 
    203             num_sal 
    204          WRITE(numout,*) '~~~~~~~~~~~~' 
    205  
    206          CALL lim_var_salprof1d(kideb,kiut) 
    207  
    208       ENDIF ! num_sal .EQ. 3 
     194      IF( num_sal == 3 )   CALL lim_var_salprof1d( kideb, kiut ) 
    209195 
    210196      !------------------------------------------------------------------------------| 
     
    212198      !------------------------------------------------------------------------------| 
    213199 
    214       ! Cox and Weeks, 1974 
    215       IF (num_sal.eq.5) THEN 
    216  
    217          WRITE(numout,*) 
    218          WRITE(numout,*) 'lim_thd_sal : Ice salinity computation module ', & 
    219             num_sal 
    220          WRITE(numout,*) '~~~~~~~~~~~~' 
    221  
    222          DO ji = kideb, kiut 
    223  
     200      IF( num_sal == 5 ) THEN      ! Cox and Weeks, 1974 
     201         ! 
     202         DO ji = kideb, kiut 
    224203            zsold = sm_i_b(ji) 
    225  
    226             IF (ht_i_b(ji).lt.0.4) THEN 
    227                sm_i_b(ji)    = 14.24 - 19.39*ht_i_b(ji)  
     204            IF( ht_i_b(ji) < 0.4 ) THEN 
     205               sm_i_b(ji) = 14.24 - 19.39 * ht_i_b(ji)  
    228206            ELSE 
    229                sm_i_b(ji)    =  7.88 - 1.59*ht_i_b(ji) 
    230                sm_i_b(ji)    = MIN(sm_i_b(ji),zsold 
     207               sm_i_b(ji) =  7.88 - 1.59 * ht_i_b(ji) 
     208               sm_i_b(ji) = MIN( sm_i_b(ji) , zsold  
    231209            ENDIF 
    232  
    233             IF ( ht_i_b(ji) .GT. 3.06918239 ) THEN  
    234                sm_i_b(ji)     = 3.0 
     210            IF( ht_i_b(ji) > 3.06918239 ) THEN  
     211               sm_i_b(ji) = 3._wp 
    235212            ENDIF 
    236  
    237213            DO jk = 1, nlay_i 
    238214               s_i_b(ji,jk)   = sm_i_b(ji) 
    239215            END DO 
    240  
    241          END DO ! ji 
    242  
     216         END DO 
     217         ! 
    243218      ENDIF ! num_sal 
    244219 
     
    247222      !------------------------------------------------------------------------------| 
    248223 
    249       IF ( num_sal .EQ. 4 ) THEN 
    250          DO ji = kideb, kiut 
    251             zji                 = MOD( npb(ji) - 1, jpi ) + 1 
    252             zjj                 = ( npb(ji) - 1 ) / jpi + 1 
     224      IF ( num_sal == 4 ) THEN 
     225         DO ji = kideb, kiut 
     226            zji = MOD( npb(ji) - 1 , jpi ) + 1 
     227            zjj =    ( npb(ji) - 1 ) / jpi + 1 
    253228            fseqv_1d(ji) = fseqv_1d(ji) + ( sss_m(zji,zjj) - bulk_sal    )               & 
    254229               &                        * rhoic * a_i_b(ji) * MAX( dh_i_bott(ji) , 0.0 ) / rdt_ice 
     
    256231      ELSE 
    257232         DO ji = kideb, kiut 
    258             zji                 = MOD( npb(ji) - 1, jpi ) + 1 
    259             zjj                 = ( npb(ji) - 1 ) / jpi + 1 
     233            zji = MOD( npb(ji) - 1 , jpi ) + 1 
     234            zjj =    ( npb(ji) - 1 ) / jpi + 1 
    260235            fseqv_1d(ji) = fseqv_1d(ji) + ( sss_m(zji,zjj) - s_i_new(ji) )               & 
    261236               &                        * rhoic * a_i_b(ji) * MAX( dh_i_bott(ji) , 0.0 ) / rdt_ice 
    262          END DO ! ji 
     237         END DO 
    263238      ENDIF 
     239      ! 
     240      IF( wrk_not_released(1, 1,2,3) )   CALL ctl_stop( 'lim_thd_lac : failed to release workspace arrays' ) 
    264241      ! 
    265242   END SUBROUTINE lim_thd_sal 
Note: See TracChangeset for help on using the changeset viewer.