New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
Changeset 2620 for branches/dev_r2586_dynamic_mem – NEMO

Ignore:
Timestamp:
2011-02-27T10:12:17+01:00 (13 years ago)
Author:
gm
Message:

dynamic mem: #785 ; SBC: move dyn allocation from nemogcm to module when possible (continuation)

Location:
branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC
Files:
24 edited

Legend:

Unmodified
Added
Removed

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/SBC/albedo.F90

    r2590 r2620  
    4747   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    4848   !! $Id$ 
    49    !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    50    !!---------------------------------------------------------------------- 
    51  
     49   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
     50   !!---------------------------------------------------------------------- 
    5251CONTAINS 
    5352 
    … …  
    6665      !!---------------------------------------------------------------------- 
    6766      USE wrk_nemo, ONLY: wrk_use, wrk_release, llwrk_use, llwrk_release 
    68       USE wrk_nemo, ONLY: llwrk_3d_1  
    69       USE wrk_nemo, ONLY: wrk_3d_6, wrk_3d_7 
     67      USE wrk_nemo, ONLY: wrk_3d_6, wrk_3d_7    ! 3D workspace 
    7068      !! 
    7169      REAL(wp), INTENT(in   ), DIMENSION(:,:,:) ::   pt_ice      !  ice surface temperature (Kelvin) 
    … …  
    8684      REAL(wp) ::   zihsc2        ! = 1 hsn >= c2 ; = 0 hsn < c2 
    8785      !! 
    88       LOGICAL,  POINTER, DIMENSION(:,:,:) ::   llmask    ! Pointer to sub-array of workspace array 
    8986      REAL(wp), POINTER, DIMENSION(:,:,:) ::   zalbfz    ! = rn_alphdi for freezing ice ; = rn_albice for melting ice 
    9087      REAL(wp), POINTER, DIMENSION(:,:,:) ::   zficeth   !  function of ice thickness 
    … …  
    9390      ijpl = SIZE( pt_ice, 3 )                     ! number of ice categories 
    9491 
    95       IF( (.not. llwrk_use(3,1)) .OR. (.not. wrk_use(3, 6,7)) )THEN 
    96          CALL ctl_stop('albedo_ice: requested workspace arrays are unavailable.') 
    97          RETURN 
    98       ELSE IF(ijpl > jpk)THEN 
    99          ! 3D workspace arrays have extent jpk in 3rd dimension - check that  
    100          ! ijpl doesn't exceed it. 
    101          CALL ctl_stop('albedo_ice: 3rd dimension of standard workspace arrays too small for them to be used here.') 
    102          RETURN 
    103       ELSE 
    104          ! Associate pointers with sub-arrays of workspace arrays 
    105          llmask  => llwrk_3d_1(:,:,1:ijpl) 
    106          zalbfz  =>   wrk_3d_6(:,:,1:ijpl) 
    107          zficeth =>   wrk_3d_7(:,:,1:ijpl) 
    108       END IF 
     92      IF( (.not. llwrk_use(3,1)) .OR. (.not. wrk_use(3, 6,7)) ) THEN 
     93         CALL ctl_stop('albedo_ice: requested workspace arrays are unavailable')   ;   RETURN 
     94      ENDIF 
     95      ! Associate pointers with sub-arrays of workspace arrays 
     96      zalbfz  =>   wrk_3d_6(:,:,1:ijpl) 
     97      zficeth =>   wrk_3d_7(:,:,1:ijpl) 
    10998 
    11099      IF( albd_init == 0 )   CALL albedo_init      ! initialization  
    … …  
    113102      !  Computation of  zficeth 
    114103      !--------------------------- 
    115       llmask(:,:,1:ijpl) = ( ph_snw == 0.e0 ) .AND. ( pt_ice >= rt0_ice ) 
    116104      ! ice free of snow and melts 
    117       WHERE( llmask(:,:,1:ijpl) )   ;   zalbfz = rn_albice 
    118       ELSEWHERE                     ;   zalbfz = rn_alphdi 
     105      WHERE     ( ph_snw == 0._wp .AND. pt_ice >= rt0_ice )   ;   zalbfz(:,:,:) = rn_albice 
     106      ELSE WHERE                                              ;   zalbfz(:,:,:) = rn_alphdi 
     107      END  WHERE 
     108 
     109      WHERE     ( 1.5  < ph_ice                     )  ;  zficeth = zalbfz 
     110      ELSE WHERE( 1.0  < ph_ice .AND. ph_ice <= 1.5 )  ;  zficeth = 0.472  + 2.0 * ( zalbfz - 0.472 ) * ( ph_ice - 1.0 ) 
     111      ELSE WHERE( 0.05 < ph_ice .AND. ph_ice <= 1.0 )  ;  zficeth = 0.2467 + 0.7049 * ph_ice              & 
     112         &                                                                 - 0.8608 * ph_ice * ph_ice     & 
     113         &                                                                 + 0.3812 * ph_ice * ph_ice * ph_ice 
     114      ELSE WHERE                                       ;  zficeth = 0.1    + 3.6    * ph_ice 
    119115      END WHERE 
    120116 
    121       DO jl = 1, ijpl 
    122          DO jj = 1, jpj 
    123             DO ji = 1, jpi 
    124                IF( ph_ice(ji,jj,jl) > 1.5 ) THEN 
    125                   zficeth(ji,jj,jl) = zalbfz(ji,jj,jl) 
    126                ELSEIF( ph_ice(ji,jj,jl) > 1.0  .AND. ph_ice(ji,jj,jl) <= 1.5 ) THEN 
    127                   zficeth(ji,jj,jl) = 0.472 + 2.0 * ( zalbfz(ji,jj,jl) - 0.472 ) * ( ph_ice(ji,jj,jl) - 1.0 ) 
    128                ELSEIF( ph_ice(ji,jj,jl) > 0.05 .AND. ph_ice(ji,jj,jl) <= 1.0 ) THEN 
    129                   zficeth(ji,jj,jl) = 0.2467 + 0.7049 * ph_ice(ji,jj,jl)                               & 
    130                      &                    - 0.8608 * ph_ice(ji,jj,jl) * ph_ice(ji,jj,jl)                 & 
    131                      &                    + 0.3812 * ph_ice(ji,jj,jl) * ph_ice(ji,jj,jl) * ph_ice (ji,jj,jl) 
    132                ELSE 
    133                   zficeth(ji,jj,jl) = 0.1 + 3.6 * ph_ice(ji,jj,jl)  
    134                ENDIF 
    135             END DO 
    136          END DO 
    137       END DO 
     117!!gm old code 
     118!      DO jl = 1, ijpl 
     119!         DO jj = 1, jpj 
     120!            DO ji = 1, jpi 
     121!               IF( ph_ice(ji,jj,jl) > 1.5 ) THEN 
     122!                  zficeth(ji,jj,jl) = zalbfz(ji,jj,jl) 
     123!               ELSEIF( ph_ice(ji,jj,jl) > 1.0  .AND. ph_ice(ji,jj,jl) <= 1.5 ) THEN 
     124!                  zficeth(ji,jj,jl) = 0.472 + 2.0 * ( zalbfz(ji,jj,jl) - 0.472 ) * ( ph_ice(ji,jj,jl) - 1.0 ) 
     125!               ELSEIF( ph_ice(ji,jj,jl) > 0.05 .AND. ph_ice(ji,jj,jl) <= 1.0 ) THEN 
     126!                  zficeth(ji,jj,jl) = 0.2467 + 0.7049 * ph_ice(ji,jj,jl)                               & 
     127!                     &                    - 0.8608 * ph_ice(ji,jj,jl) * ph_ice(ji,jj,jl)                 & 
     128!                     &                    + 0.3812 * ph_ice(ji,jj,jl) * ph_ice(ji,jj,jl) * ph_ice (ji,jj,jl) 
     129!               ELSE 
     130!                  zficeth(ji,jj,jl) = 0.1 + 3.6 * ph_ice(ji,jj,jl)  
     131!               ENDIF 
     132!            END DO 
     133!         END DO 
     134!      END DO 
     135!!gm end old code 
    138136       
    139137      !-----------------------------------------------  
    … …  
    174172      pa_ice_os(:,:,:) = pa_ice_cs(:,:,:) + rn_cloud       ! Oberhuber correction 
    175173      ! 
    176       IF( (.not. llwrk_release(3, 1)) .OR. (.not. wrk_release(3, 6,7)) )THEN 
    177          CALL ctl_stop('albedo_ice: failed to release workspace arrays.') 
    178       END IF 
     174      IF( .not. wrk_release(3, 6,7) )   CALL ctl_stop('albedo_ice: failed to release workspace arrays') 
    179175      ! 
    180176   END SUBROUTINE albedo_ice 
    … …  
    186182      !!  
    187183      !! ** Purpose :   Computation of the albedo of the ocean 
    188       !! 
    189       !! ** Method  :   .... 
    190184      !!---------------------------------------------------------------------- 
    191185      REAL(wp), DIMENSION(:,:), INTENT(out) ::   pa_oce_os   !  albedo of ocean under overcast sky 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/SBC/cpl_oasis3.F90

    r2590 r2620  
    66   !!===================================================================== 
    77   !! History :    
    8    !!   9.0  !  04-06  (R. Redler, NEC Laboratories Europe, St Augustin, Germany) Original code 
    9    !!   " "  !  04-11  (R. Redler, NEC Laboratories Europe; N. Keenlyside, W. Park, IFM-GEOMAR, Kiel, Germany) revision 
     8   !!   9.0  !  04-06  (R. Redler, NEC Laboratories Europe, Germany) Original code 
     9   !!   " "  !  04-11  (R. Redler, NEC Laboratories Europe; N. Keenlyside, W. Park, IFM-GEOMAR, Germany) revision 
    1010   !!   " "  !  04-11  (V. Gayler, MPI M&D) Grid writing 
    1111   !!   " "  !  05-08  (R. Redler, W. Park) frld initialization, paral(2) revision 
    … …  
    1717   !!---------------------------------------------------------------------- 
    1818   !!   'key_oasis3'                    coupled Ocean/Atmosphere via OASIS3 
    19    !!---------------------------------------------------------------------- 
    2019   !!---------------------------------------------------------------------- 
    2120   !!   cpl_prism_init     : initialization of coupled mode communication 
    … …  
    3433   USE in_out_manager               ! I/O manager 
    3534   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
     35 
    3636   IMPLICIT NONE 
    3737   PRIVATE 
    38 ! 
    39    LOGICAL, PUBLIC, PARAMETER :: lk_cpl = .TRUE.   ! coupled flag 
    40    INTEGER, PUBLIC            :: OASIS_Rcv  = 1    ! return code if received field 
    41    INTEGER, PUBLIC            :: OASIS_idle = 0    ! return code if nothing done by oasis 
     38 
     39   PUBLIC cpl_prism_init 
     40   PUBLIC cpl_prism_define 
     41   PUBLIC cpl_prism_snd 
     42   PUBLIC cpl_prism_rcv 
     43   PUBLIC cpl_prism_freq 
     44   PUBLIC cpl_prism_finalize 
     45 
     46   LOGICAL, PUBLIC, PARAMETER :: lk_cpl = .TRUE.   !: coupled flag 
     47   INTEGER, PUBLIC            :: OASIS_Rcv  = 1    !: return code if received field 
     48   INTEGER, PUBLIC            :: OASIS_idle = 0    !: return code if nothing done by oasis 
    4249   INTEGER                    :: ncomp_id          ! id returned by prism_init_comp 
    4350   INTEGER                    :: nerror            ! return error code 
    … …  
    4552   INTEGER, PARAMETER :: nmaxfld=40    ! Maximum number of coupling fields 
    4653    
    47    TYPE, PUBLIC ::   FLD_CPL            ! Type for coupling field information 
     54   TYPE, PUBLIC ::   FLD_CPL            !: Type for coupling field information 
    4855      LOGICAL            ::   laction   ! To be coupled or not 
    4956      CHARACTER(len = 8) ::   clname    ! Name of the coupling field    
    … …  
    5360   END TYPE FLD_CPL 
    5461 
    55    TYPE(FLD_CPL), DIMENSION(nmaxfld), PUBLIC :: srcv, ssnd   ! Coupling fields 
     62   TYPE(FLD_CPL), DIMENSION(nmaxfld), PUBLIC :: srcv, ssnd   !: Coupling fields 
    5663 
    5764   REAL(wp), DIMENSION(:,:), ALLOCATABLE :: exfld  ! Temporary buffer for receiving 
    58  
    59    !! Routine accessibility 
    60    PUBLIC cpl_prism_init 
    61    PUBLIC cpl_prism_define 
    62    PUBLIC cpl_prism_snd 
    63    PUBLIC cpl_prism_rcv 
    64    PUBLIC cpl_prism_freq 
    65    PUBLIC cpl_prism_finalize 
    6665 
    6766   !!---------------------------------------------------------------------- 
    6867   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    6968   !! $Id$ 
    70    !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    71    !!---------------------------------------------------------------------- 
    72  
     69   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
     70   !!---------------------------------------------------------------------- 
    7371CONTAINS 
    7472 
    75    SUBROUTINE cpl_prism_init (kl_comm)  
    76  
     73   SUBROUTINE cpl_prism_init( kl_comm ) 
    7774      !!------------------------------------------------------------------- 
    7875      !!             ***  ROUTINE cpl_prism_init  *** 
    … …  
    8380      !! ** Method  :   OASIS3 MPI communication  
    8481      !!-------------------------------------------------------------------- 
    85       INTEGER, INTENT(   OUT )   :: kl_comm       ! local communicator of the model 
     82      INTEGER, INTENT(out) ::   kl_comm   ! local communicator of the model 
    8683      !!-------------------------------------------------------------------- 
    8784 
    … …  
    103100      IF ( nerror /= PRISM_Ok ) & 
    104101         CALL prism_abort_proto (ncomp_id, 'cpl_prism_init','Failure in prism_get_localcomm_proto' ) 
    105  
     102      ! 
    106103   END SUBROUTINE cpl_prism_init 
    107104 
    108105 
    109    SUBROUTINE cpl_prism_define (krcv, ksnd) 
    110  
     106   SUBROUTINE cpl_prism_define( krcv, ksnd ) 
    111107      !!------------------------------------------------------------------- 
    112108      !!             ***  ROUTINE cpl_prism_define  *** 
    … …  
    117113      !! ** Method  :   OASIS3 MPI communication  
    118114      !!-------------------------------------------------------------------- 
    119       INTEGER, INTENT( IN    )   :: krcv, ksnd     ! Number of received and sent coupling fields 
    120       ! 
    121       INTEGER                    :: id_part 
    122       INTEGER                    :: paral(5)       ! OASIS3 box partition 
    123       INTEGER                    :: ishape(2,2)    ! shape of arrays passed to PSMILe 
    124       INTEGER                    :: ji             ! local loop indicees 
    125       !! 
     115      INTEGER, INTENT(in) ::   krcv, ksnd     ! Number of received and sent coupling fields 
     116      ! 
     117      INTEGER :: id_part 
     118      INTEGER :: paral(5)       ! OASIS3 box partition 
     119      INTEGER :: ishape(2,2)    ! shape of arrays passed to PSMILe 
     120      INTEGER :: ji             ! local loop indicees 
    126121      !!-------------------------------------------------------------------- 
    127122 
    … …  
    142137      ! 
    143138      ALLOCATE(exfld(nlei-nldi+1, nlej-nldj+1), stat = nerror) 
    144       IF (nerror > 0) THEN 
    145          CALL prism_abort_proto ( ncomp_id, 'cpl_prism_define', 'Failure in allocating exfld') 
    146          RETURN 
     139      IF( nerror > 0 ) THEN 
     140         CALL prism_abort_proto ( ncomp_id, 'cpl_prism_define', 'Failure in allocating exfld')   ;   RETURN 
    147141      ENDIF 
    148142      ! 
    … …  
    197191       
    198192      CALL prism_enddef_proto(nerror) 
    199       IF ( nerror /= PRISM_Ok )   CALL prism_abort_proto ( ncomp_id, 'cpl_prism_define', 'Failure in prism_enddef') 
    200        
     193      IF( nerror /= PRISM_Ok )   CALL prism_abort_proto ( ncomp_id, 'cpl_prism_define', 'Failure in prism_enddef') 
     194      ! 
    201195   END SUBROUTINE cpl_prism_define 
    202196    
    203197    
    204198   SUBROUTINE cpl_prism_snd( kid, kstep, pdata, kinfo ) 
    205  
    206199      !!--------------------------------------------------------------------- 
    207200      !!              ***  ROUTINE cpl_prism_snd  *** 
    … …  
    210203      !!      like sst or ice cover to the coupler or remote application. 
    211204      !!---------------------------------------------------------------------- 
    212       !! * Arguments 
    213       !! 
    214       INTEGER,                      INTENT( IN    )   :: kid       ! variable index in the array 
    215       INTEGER,                      INTENT(   OUT )   :: kinfo     ! OASIS3 info argument 
    216       INTEGER,                      INTENT( IN    )   :: kstep     ! ocean time-step in seconds 
    217       REAL(wp), DIMENSION(jpi,jpj), INTENT( IN    )   :: pdata 
    218       !! 
    219       !! 
     205      INTEGER                 , INTENT(in   ) ::   kid       ! variable index in the array 
     206      INTEGER                 , INTENT(  out) ::   kinfo     ! OASIS3 info argument 
     207      INTEGER                 , INTENT(in   ) ::   kstep     ! ocean time-step in seconds 
     208      REAL(wp), DIMENSION(:,:), INTENT(in   ) ::   pdata 
    220209      !!-------------------------------------------------------------------- 
    221210      ! 
    … …  
    236225            WRITE(numout,*) '     -     Sum value is ', SUM(pdata) 
    237226            WRITE(numout,*) '****************' 
    238         ENDIF 
    239      ENDIF 
     227         ENDIF 
     228      ENDIF 
     229      ! 
    240230    END SUBROUTINE cpl_prism_snd 
    241231 
    242232 
    243233   SUBROUTINE cpl_prism_rcv( kid, kstep, pdata, kinfo ) 
    244  
    245234      !!--------------------------------------------------------------------- 
    246235      !!              ***  ROUTINE cpl_prism_rcv  *** 
    … …  
    249238      !!      like stresses and fluxes from the coupler or remote application. 
    250239      !!---------------------------------------------------------------------- 
    251       INTEGER,                      INTENT( IN    )   :: kid       ! variable index in the array 
    252       INTEGER,                      INTENT( IN    )   :: kstep     ! ocean time-step in seconds 
    253       REAL(wp),     DIMENSION(:,:), INTENT( INOUT )   :: pdata     ! IN to keep the value if nothing is done 
    254       INTEGER,                      INTENT(   OUT )   :: kinfo     ! OASIS3 info argument 
     240      INTEGER                 , INTENT(in   ) ::  kid       ! variable index in the array 
     241      INTEGER                 , INTENT(in   ) ::  kstep     ! ocean time-step in seconds 
     242      REAL(wp), DIMENSION(:,:), INTENT(inout) ::  pdata     ! IN to keep the value if nothing is done 
     243      INTEGER                 , INTENT(  out) ::  kinfo     ! OASIS3 info argument 
    255244      !! 
    256245      LOGICAL                :: llaction 
    … …  
    291280         kinfo = OASIS_idle      
    292281      ENDIF 
    293  
     282      ! 
    294283   END SUBROUTINE cpl_prism_rcv 
    295284 
    296285 
    297286   FUNCTION cpl_prism_freq( kid )   
    298  
    299287      !!--------------------------------------------------------------------- 
    300288      !!              ***  ROUTINE cpl_prism_freq  *** 
    … …  
    304292      INTEGER,INTENT( IN )   :: kid              ! variable index  
    305293      INTEGER                :: cpl_prism_freq   ! coupling frequency 
     294      !!---------------------------------------------------------------------- 
    306295      cpl_prism_freq = ig_def_freq( kid ) 
    307  
     296      ! 
    308297   END FUNCTION cpl_prism_freq 
    309298 
    310299 
    311300   SUBROUTINE cpl_prism_finalize 
    312  
    313301      !!--------------------------------------------------------------------- 
    314302      !!              ***  ROUTINE cpl_prism_finalize  *** 
    … …  
    318306      !!      MPI communication. 
    319307      !!---------------------------------------------------------------------- 
    320  
     308      ! 
    321309      DEALLOCATE(exfld) 
    322310      CALL prism_terminate_proto ( nerror )          
    323  
     311      ! 
    324312   END SUBROUTINE cpl_prism_finalize 
    325313 
    326314#else 
    327  
    328    !!---------------------------------------------------------------------- 
    329    !!   Default case                                Forced Ocean/Atmosphere 
    330    !!---------------------------------------------------------------------- 
    331    !!   Empty module 
     315   !!---------------------------------------------------------------------- 
     316   !!   Default case          Dummy module          Forced Ocean/Atmosphere 
    332317   !!---------------------------------------------------------------------- 
    333318   USE in_out_manager               ! I/O manager 
    … …  
    335320   PUBLIC cpl_prism_init 
    336321   PUBLIC cpl_prism_finalize 
    337  
    338322CONTAINS 
    339  
    340323   SUBROUTINE cpl_prism_init (kl_comm)  
    341       INTEGER, INTENT(   OUT )   :: kl_comm       ! local communicator of the model 
     324      INTEGER, INTENT(out)   :: kl_comm       ! local communicator of the model 
    342325      kl_comm = -1 
    343326      WRITE(numout,*) 'cpl_prism_init: Error you sould not be there...' 
    344327   END SUBROUTINE cpl_prism_init 
    345  
    346328   SUBROUTINE cpl_prism_finalize 
    347329      WRITE(numout,*) 'cpl_prism_finalize: Error you sould not be there...' 
    348330   END SUBROUTINE cpl_prism_finalize 
    349  
    350331#endif 
    351332 
     333   !!===================================================================== 
    352334END MODULE cpl_oasis3 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/SBC/cpl_oasis4.F90

    r2590 r2620  
    55   !!===================================================================== 
    66   !! History :    
    7    !!   9.0  !  04-06  (R. Redler, NEC Laboratories Europe, St Augustin, Germany) Original code 
    8    !!   " "  !  04-11  (R. Redler, NEC Laboratories Europe; N. Keenlyside, W. Park, IFM-GEOMAR, Kiel, Germany) revision 
    9    !!   " "  !  04-11  (V. Gayler, MPI M&D) Grid writing 
    10    !!   " "  !  05-08  (R. Redler, W. Park) frld initialization, paral(2) revision 
    11    !!   " "  !  05-09  (R. Redler) extended to allow for communication over root only 
    12    !!   " "  !  06-01  (W. Park) modification of physical part 
    13    !!   " "  !  06-02  (R. Redler, W. Park) buffer array fix for root exchange 
    14    !!   " "  !  2010   (E. Maisonnave and S. Masson) complete rewrite 
     7   !!   9.0  !  2004-06  (R. Redler, NEC Laboratories Europe, St Augustin, Germany) Original code 
     8   !!    -   !  2004-11  (R. Redler, NEC Laboratories Europe; N. Keenlyside, W. Park, IFM-GEOMAR, Kiel, Germany) revision 
     9   !!    -   !  2004-11  (V. Gayler, MPI M&D) Grid writing 
     10   !!    -   !  2005-08  (R. Redler, W. Park) frld initialization, paral(2) revision 
     11   !!    -   !  2005-09  (R. Redler) extended to allow for communication over root only 
     12   !!    -   !  2006-01  (W. Park) modification of physical part 
     13   !!    -   !  2006-02  (R. Redler, W. Park) buffer array fix for root exchange 
     14   !!    -   !  2010-10  (E. Maisonnave and S. Masson) complete rewrite 
    1515   !!---------------------------------------------------------------------- 
    1616#if defined key_oasis4 
    1717   !!---------------------------------------------------------------------- 
    1818   !!   'key_oasis4'                    coupled Ocean/Atmosphere via OASIS4 
    19    !!---------------------------------------------------------------------- 
    2019   !!---------------------------------------------------------------------- 
    2120   !!   cpl_prism_init     : initialization of coupled mode communication 
    … …  
    3534   IMPLICIT NONE 
    3635   PRIVATE 
    37 ! 
     36 
     37   PUBLIC cpl_prism_init 
     38   PUBLIC cpl_prism_define 
     39   PUBLIC cpl_prism_snd 
     40   PUBLIC cpl_prism_rcv 
     41   PUBLIC cpl_prism_update_time 
     42   PUBLIC cpl_prism_finalize 
     43    
    3844!   LOGICAL, PUBLIC, PARAMETER :: lk_cpl = .TRUE.    ! coupled flag 
    3945   INTEGER                    :: ncomp_id           ! id returned by prism_init_comp 
    … …  
    5965   TYPE(PRISM_Time_struct), PUBLIC    :: date_bound(2)   ! date info for send operation 
    6066 
    61  
    62    !! Routine accessibility 
    63    PUBLIC cpl_prism_init 
    64    PUBLIC cpl_prism_define 
    65    PUBLIC cpl_prism_snd 
    66    PUBLIC cpl_prism_rcv 
    67    PUBLIC cpl_prism_update_time 
    68    PUBLIC cpl_prism_finalize 
    69  
    70    !!---------------------------------------------------------------------- 
    71    !!   OPA 9.0 , LOCEAN-IPSL (2006)  
    72    !! $Header$  
    73    !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 
    74    !!---------------------------------------------------------------------- 
    75  
     67   !!---------------------------------------------------------------------- 
     68   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
     69   !! $Id$ 
     70   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
     71   !!---------------------------------------------------------------------- 
    7672CONTAINS 
    7773 
    78    SUBROUTINE cpl_prism_init (kl_comm)  
    79  
     74   SUBROUTINE cpl_prism_init( kl_comm )  
    8075      !!------------------------------------------------------------------- 
    8176      !!             ***  ROUTINE cpl_prism_init  *** 
    … …  
    8681      !! ** Method  :   OASIS4 MPI communication  
    8782      !!-------------------------------------------------------------------- 
    88       INTEGER, INTENT(   OUT )   :: kl_comm       ! local communicator of the model 
    89       ! 
     83      INTEGER, INTENT(out) ::   kl_comm   ! local communicator of the model 
     84      !!-------------------------------------------------------------------- 
    9085       
    9186      CALL prism_init( 'nemo', nerror ) 
    … …  
    10297      CALL prism_get_localcomm( ncomp_id, kl_comm, nerror ) 
    10398      IF( nerror /= PRISM_Success )   CALL prism_abort( ncomp_id, 'cpl_prism_init', 'Failure in prism_get_localcomm' ) 
    104  
    105  
     99      ! 
    106100   END SUBROUTINE cpl_prism_init 
    107101 
    108102 
    109    SUBROUTINE cpl_prism_define (krcv, ksnd) 
    110  
     103   SUBROUTINE cpl_prism_define( krcv, ksnd ) 
    111104      !!------------------------------------------------------------------- 
    112105      !!             ***  ROUTINE cpl_prism_define  *** 
    … …  
    120113      USE wrk_nemo, ONLY: zclo => wrk_3d_1, zcla => wrk_3d_2 
    121114      USE wrk_nemo, ONLY: zlon => wrk_2d_1, zlat => wrk_2d_2 
    122       !! 
    123       INTEGER, INTENT( IN    )  :: krcv, ksnd     ! Number of received and sent coupling fields 
     115      ! 
     116      INTEGER, INTENT(in) :: krcv, ksnd     ! Number of received and sent coupling fields 
    124117      ! 
    125118      INTEGER, DIMENSION(4)      :: igrid     ! ids returned by prism_def_grid 
    126119      INTEGER, DIMENSION(4)      :: iptid     ! ids returned by prism_set_points 
    127  
    128       INTEGER, DIMENSION(4)      :: imskid  ! ids returned by prism_set_mask 
    129       INTEGER, DIMENSION(4)      :: iishift     !  
    130       INTEGER, DIMENSION(4)      :: ijshift    !  
     120      INTEGER, DIMENSION(4)      :: imskid    ! ids returned by prism_set_mask 
     121      INTEGER, DIMENSION(4)      :: iishift   !  
     122      INTEGER, DIMENSION(4)      :: ijshift   !  
    131123      INTEGER, DIMENSION(4)      :: iioff     !  
    132       INTEGER, DIMENSION(4)      :: ijoff    !  
    133       INTEGER, DIMENSION(4)      :: itmp    !  
    134       INTEGER, DIMENSION(1,3)    :: iextent    !  
    135       INTEGER, DIMENSION(1,3)    :: ioffset    !  
    136  
    137  
    138       INTEGER                    :: ishape(2,3)     ! shape of arrays passed to PSMILe 
     124      INTEGER, DIMENSION(4)      :: ijoff     !  
     125      INTEGER, DIMENSION(4)      :: itmp      !  
     126      INTEGER, DIMENSION(1,3)    :: iextent   !  
     127      INTEGER, DIMENSION(1,3)    :: ioffset   !  
     128 
     129      INTEGER                    :: ishape(2,3)    ! shape of arrays passed to PSMILe 
    139130      INTEGER                    :: data_type      ! data type of transients 
    140  
    141131 
    142132      LOGICAL                    :: new_points 
    … …  
    144134      LOGICAL, ALLOCATABLE, SAVE :: llmask(:,:,:) ! jpi,jpj,1 
    145135 
    146       INTEGER                    :: ji, jj, jg, jc     ! local loop indicees 
    147       INTEGER                    :: ii,ij     ! index 
    148       INTEGER, DIMENSION(1)      :: ind     ! index 
     136      INTEGER                    :: ji, jj, jg, jc   ! local loop indicees 
     137      INTEGER                    :: ii, ij           ! index 
     138      INTEGER, DIMENSION(1)      :: ind              ! index 
    149139 
    150140      CHARACTER(len=32)          :: clpt_name     ! name of the grid points 
    … …  
    154144      TYPE(PRISM_Time_struct)    :: tmpdate 
    155145      INTEGER                    :: idate_incr      ! date increment 
    156       !! 
    157       !!-------------------------------------------------------------------- 
    158  
    159       IF( (.not. wrk_use(3, 1,2)) .OR. (.not. wrk_use(2, 1,2)) )THEN 
    160          CALL ctl_stop('cpl_prism_define: ERROR: requested workspace arrays are unavailable.') 
    161          RETURN 
    162       END IF 
     146      !!-------------------------------------------------------------------- 
     147 
     148      IF( .NOT. wrk_use(3, 1,2) .OR. .NOT. wrk_use(2, 1,2) )THEN 
     149         CALL ctl_stop('cpl_prism_define: ERROR: requested workspace arrays are unavailable.')   ;   RETURN 
     150      ENDIF 
    163151 
    164152      IF(lwp) WRITE(numout,*) 
    … …  
    333321      IF ( nerror /= PRISM_Success )   CALL prism_abort ( ncomp_id, 'cpl_prism_define', 'Failure in prism_enddef') 
    334322       
    335       IF( (.not. wrk_release(3, 1,2)) .OR. (.not. wrk_release(2, 1,2)) )THEN 
    336          CALL ctl_stop('cpl_prism_define: ERROR: failed to release workspace arrays.') 
    337       END IF 
    338  
     323      IF( .not. wrk_release(3, 1,2) .OR.   & 
     324          .not. wrk_release(2, 1,2)   )   CALL ctl_stop('cpl_prism_define: failed to release workspace arrays') 
     325      ! 
    339326   END SUBROUTINE cpl_prism_define 
    340327    
    341328    
    342329   SUBROUTINE cpl_prism_snd( kid, kstep, pdata, kinfo ) 
    343  
    344330      !!--------------------------------------------------------------------- 
    345331      !!              ***  ROUTINE cpl_prism_snd  *** 
    … …  
    348334      !!      like sst or ice cover to the coupler or remote application. 
    349335      !!---------------------------------------------------------------------- 
    350       !! * Arguments 
    351       !! 
    352       INTEGER,                      INTENT( IN    )   :: kid       ! variable intex in the array 
    353       INTEGER,                      INTENT(   OUT )   :: kinfo     ! OASIS4 info argument 
    354       INTEGER,                      INTENT( IN    )   :: kstep     ! ocean time-step in seconds 
    355       REAL(wp),     DIMENSION(:,:), INTENT( IN    )   :: pdata 
    356       !! 
    357       !! 
     336      INTEGER                 , INTENT(in   ) ::   kid     ! variable intex in the array 
     337      INTEGER                 , INTENT(  out) ::   kinfo   ! OASIS4 info argument 
     338      INTEGER                 , INTENT(in   ) ::   kstep   ! ocean time-step in seconds 
     339      REAL(wp), DIMENSION(:,:), INTENT(in   ) ::   pdata 
    358340      !!-------------------------------------------------------------------- 
    359341      ! 
    … …  
    365347         &                                               'Failure in prism_put for '//TRIM(ssnd(kid)%clname) ) 
    366348 
    367       IF ( ln_ctl ) THEN         
     349      IF( ln_ctl ) THEN         
    368350         IF ( kinfo >= PRISM_Cpl     .OR. kinfo == PRISM_Rst .OR.   & 
    369351            & kinfo == PRISM_RstTimeop ) THEN 
    … …  
    377359            WRITE(numout,*) '     -     Sum value is ', SUM(pdata) 
    378360            WRITE(numout,*) '****************' 
    379         ENDIF 
    380      ENDIF 
    381     END SUBROUTINE cpl_prism_snd 
     361         ENDIF 
     362      ENDIF 
     363      ! 
     364   END SUBROUTINE cpl_prism_snd 
    382365 
    383366 
    384367   SUBROUTINE cpl_prism_rcv( kid, kstep, pdata, kinfo ) 
    385  
    386368      !!--------------------------------------------------------------------- 
    387369      !!              ***  ROUTINE cpl_prism_rcv  *** 
    … …  
    390372      !!      like stresses and fluxes from the coupler or remote application. 
    391373      !!---------------------------------------------------------------------- 
    392       INTEGER,                      INTENT( IN    )   :: kid       ! variable intex in the array 
    393       INTEGER,                      INTENT( IN    )   :: kstep     ! ocean time-step in seconds 
    394       REAL(wp),     DIMENSION(:,:), INTENT( INOUT )   :: pdata     ! IN to keep the value if nothing is done 
    395       INTEGER,                      INTENT(   OUT )   :: kinfo     ! OASIS4 info argument 
    396       !! 
     374      INTEGER                 , INTENT(in   ) ::   kid     ! variable intex in the array 
     375      INTEGER                 , INTENT(in   ) ::   kstep   ! ocean time-step in seconds 
     376      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pdata   ! IN to keep the value if nothing is done 
     377      INTEGER                 , INTENT(  out) ::   kinfo   ! OASIS4 info argument 
     378      ! 
    397379      LOGICAL                :: llaction 
    398380      !!-------------------------------------------------------------------- 
    … …  
    435417         kinfo = OASIS_idle      
    436418      ENDIF 
    437  
    438  
     419      ! 
    439420   END SUBROUTINE cpl_prism_rcv 
    440421 
    441422 
    442423   SUBROUTINE cpl_prism_finalize 
    443  
    444424      !!--------------------------------------------------------------------- 
    445425      !!              ***  ROUTINE cpl_prism_finalize  *** 
    … …  
    449429      !!      MPI communication. 
    450430      !!---------------------------------------------------------------------- 
    451  
     431      ! 
    452432      DEALLOCATE(exfld) 
    453433      CALL prism_terminate ( nerror )          
    454  
     434      ! 
    455435   END SUBROUTINE cpl_prism_finalize 
    456436 
     437 
    457438   SUBROUTINE cpl_prism_update_time(kt) 
    458  
    459439      !!--------------------------------------------------------------------- 
    460440      !!              ***  ROUTINE cpl_prism_update_time  *** 
    461441      !! 
    462442      !! ** Purpose : - Increment date with model timestep 
    463       !!      called explicitly at the end of each timestep 
     443      !!                called explicitly at the end of each timestep 
    464444      !!---------------------------------------------------------------------- 
    465  
    466       INTEGER, INTENT(in) ::   kt       ! ocean model time step index 
    467  
    468       TYPE(PRISM_Time_struct)    :: tmpdate 
    469       INTEGER                    :: idate_incr     ! date increment 
    470  
    471  
    472       IF( kt == nit000 ) THEN 
    473       ! 
    474       ! Define the actual date  
    475       ! 
    476       ! date is determined by adding days since beginning of the run to the corresponding initial date. 
    477       ! Note that OPA internal info about the start date of the experiment is bypassed. 
    478       ! Instead we rely sololy on the info provided by the SCC.xml file. 
    479       ! 
     445      INTEGER, INTENT(in) ::   kt   ! ocean model time step index 
     446 
     447      TYPE(PRISM_Time_struct) ::   tmpdate 
     448      INTEGER                 ::   idate_incr   ! date increment 
     449      !!---------------------------------------------------------------------- 
     450 
     451      IF( kt == nit000 ) THEN      ! Define the actual date  
     452         ! 
     453         ! date is determined by adding days since beginning of the run to the corresponding initial date. 
     454         ! Note that OPA internal info about the start date of the experiment is bypassed. 
     455         ! Instead we rely sololy on the info provided by the SCC.xml file. 
     456         ! 
    480457         date = PRISM_Jobstart_date 
    481458         ! 
    … …  
    486463         tmpdate = date   ;   CALL PRISM_calc_newdate ( tmpdate, -idate_incr, nerror )   ;   date_bound(1) = tmpdate 
    487464         tmpdate = date   ;   CALL PRISM_calc_newdate ( tmpdate,  idate_incr, nerror )   ;   date_bound(2) = tmpdate 
    488  
    489       ELSE 
    490       ! 
    491       ! Date update 
    492       ! 
     465         ! 
     466      ELSE      ! Date update 
     467         ! 
    493468         idate_incr  = rdttra(1) 
    494469         CALL PRISM_calc_newdate( date, idate_incr, nerror ) 
    … …  
    497472         CALL PRISM_calc_newdate( tmpdate, idate_incr, nerror ) 
    498473         date_bound(2) = tmpdate 
    499  
     474         ! 
    500475      END IF 
    501  
     476      ! 
    502477   END SUBROUTINE cpl_prism_update_time 
    503478 
    504479#endif 
    505480 
     481   !!===================================================================== 
    506482END MODULE cpl_oasis4 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/SBC/fldread.F90

    r2590 r2620  
    44   !! Ocean forcing:  read input field for surface boundary condition 
    55   !!===================================================================== 
    6    !! History :  9.0  !  06-06  (G. Madec) Original code 
    7    !!                 !  05-08  (S. Alderson) Modified for Interpolation in memory 
    8    !!                 !         from input grid to model grid 
     6   !! History :  2.0  !  06-2006  (S. Masson, G. Madec) Original code 
     7   !!                 !  05-2008  (S. Alderson) Modified for Interpolation in memory 
     8   !!                 !                         from input grid to model grid 
    99   !!---------------------------------------------------------------------- 
    1010 
    … …  
    3333      CHARACTER(len = 34)  ::   wname       ! generic name of a NetCDF weights file to be used, blank if not 
    3434      CHARACTER(len = 34)  ::   vcomp       ! symbolic component name if a vector that needs rotation 
    35                                             ! a string starting with "U" or "V" for each component    
    36                                             ! chars 2 onwards identify which components go together   
     35      !                                     ! a string starting with "U" or "V" for each component    
     36      !                                     ! chars 2 onwards identify which components go together   
    3737   END TYPE FLD_N 
    3838 
    … …  
    5151      REAL(wp) , ALLOCATABLE, DIMENSION(:,:,:,:) ::   fdta       ! 2 consecutive record of input fields 
    5252      CHARACTER(len = 256)            ::   wgtname      ! current name of the NetCDF weight file acting as a key 
    53                                                         ! into the WGTLIST structure 
     53      !                                                 ! into the WGTLIST structure 
    5454      CHARACTER(len = 34)             ::   vcomp        ! symbolic name for a vector component that needs rotation 
    5555      LOGICAL                         ::   rotn         ! flag to indicate whether field has been rotated 
    … …  
    6565      INTEGER , DIMENSION(2)                  ::   ddims        ! shape of input grid 
    6666      INTEGER , DIMENSION(2)                  ::   botleft      ! top left corner of box in input grid containing  
    67                                                                 ! current processor grid 
     67      !                                                         ! current processor grid 
    6868      INTEGER , DIMENSION(2)                  ::   topright     ! top right corner of box  
    6969      INTEGER                                 ::   jpiwgt       ! width of box on input grid 
    … …  
    7272      INTEGER                                 ::   nestid       ! for agrif, keep track of nest we're in 
    7373      INTEGER                                 ::   overlap      ! =0 when cyclic grid has no overlapping EW columns 
    74                                                                 ! =>1 when they have one or more overlapping columns       
    75                                                                 ! =-1 not cyclic 
     74      !                                                         ! =>1 when they have one or more overlapping columns       
     75      !                                                         ! =-1 not cyclic 
    7676      LOGICAL                                 ::   cyclic       ! east-west cyclic or not 
    7777      INTEGER,  DIMENSION(:,:,:), POINTER     ::   data_jpi     ! array of source integers 
    … …  
    9393   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    9494   !! $Id$ 
    95    !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
     95   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    9696   !!---------------------------------------------------------------------- 
    97  
    9897CONTAINS 
    9998 
    … …  
    259258      !! ** Purpose :  - if time interpolation, read before data  
    260259      !!               - open current year file 
    261       !! 
    262       !! ** Method  :    
    263260      !!---------------------------------------------------------------------- 
    264261      INTEGER  , INTENT(in   ) ::   kn_fsbc   ! sbc computation period (in time step)  
    … …  
    408405      !!                  nrec_a(1): record number 
    409406      !!                  nrec_b(2) and nrec_a(2): time of the beginning and end of the record (for print only) 
    410       !! 
    411       !! ** Method  :    
    412407      !!---------------------------------------------------------------------- 
    413408      INTEGER  , INTENT(in   )           ::   kn_fsbc   ! sbc computation period (in time step)  
    … …  
    555550      !! 
    556551      !! ** Purpose :   read the data 
    557       !! 
    558       !! ** Method  :    
    559       !!---------------------------------------------------------------------- 
    560       TYPE(FLD), INTENT(inout)   ::   sdjf   ! input field related variables 
    561       !! 
    562       INTEGER                    ::   ipk    ! number of vertical levels of sdjf%fdta ( 2D: ipk=1 ; 3D: ipk=jpk ) 
    563       INTEGER                    ::   iw     ! index into wgts array 
     552      !!---------------------------------------------------------------------- 
     553      TYPE(FLD), INTENT(inout) ::   sdjf   ! input field related variables 
     554      !! 
     555      INTEGER                  ::   ipk    ! number of vertical levels of sdjf%fdta ( 2D: ipk=1 ; 3D: ipk=jpk ) 
     556      INTEGER                  ::   iw     ! index into wgts array 
    564557      !!--------------------------------------------------------------------- 
    565558             
    … …  
    593586      !! 
    594587      !! ** Purpose :   Vector fields may need to be rotated onto the local grid direction 
    595       !! 
    596       !! ** Method  :    
    597588      !!---------------------------------------------------------------------- 
    598589      USE wrk_nemo, ONLY: wrk_use, wrk_release 
    599       USE wrk_nemo, ONLY: utmp => wrk_2d_4, vtmp => wrk_2d_5 
     590      USE wrk_nemo, ONLY: utmp => wrk_2d_4, vtmp => wrk_2d_5      ! 2D workspace 
    600591      !! 
    601592      INTEGER  , INTENT(in   )               ::   kt        ! ocean time step 
    … …  
    609600      !!--------------------------------------------------------------------- 
    610601 
    611       IF(.not. wrk_use(2, 4,5))THEN 
    612          CALL ctl_stop('fld_rot: ERROR: requested workspace arrays are unavailable.') 
    613          RETURN 
     602      IF(.not. wrk_use(2, 4,5) ) THEN 
     603         CALL ctl_stop('fld_rot: ERROR: requested workspace arrays are unavailable.')   ;   RETURN 
    614604      END IF 
    615605 
    … …  
    646636          ENDIF 
    647637       END DO 
    648  
    649       IF(.not. wrk_release(2, 4,5))THEN 
    650          CALL ctl_stop('fld_rot: ERROR: failed to release workspace arrays.') 
    651       END IF 
    652  
     638      ! 
     639      IF(.not. wrk_release(2, 4,5) )    CALL ctl_stop('fld_rot: ERROR: failed to release workspace arrays.') 
     640      ! 
    653641   END SUBROUTINE fld_rot 
    654642 
    … …  
    659647      !! 
    660648      !! ** Purpose :   update the file name and open the file 
    661       !! 
    662       !! ** Method  :    
    663       !!---------------------------------------------------------------------- 
    664       TYPE(FLD), INTENT(inout)           ::   sdjf                  ! input field related variables 
    665       INTEGER  , INTENT(in   )           ::   kyear                 ! year value 
    666       INTEGER  , INTENT(in   )           ::   kmonth                ! month value 
    667       INTEGER  , INTENT(in   )           ::   kday                  ! day value 
    668       LOGICAL  , INTENT(in   ), OPTIONAL ::   ldstop                ! stop if open to read a non-existing file (default = .TRUE.) 
     649      !!---------------------------------------------------------------------- 
     650      TYPE(FLD)        , INTENT(inout) ::   sdjf     ! input field related variables 
     651      INTEGER          , INTENT(in   ) ::   kyear    ! year value 
     652      INTEGER          , INTENT(in   ) ::   kmonth   ! month value 
     653      INTEGER          , INTENT(in   ) ::   kday     ! day value 
     654      LOGICAL, OPTIONAL, INTENT(in   ) ::   ldstop   ! stop if open to read a non-existing file (default = .TRUE.) 
     655      !!---------------------------------------------------------------------- 
    669656 
    670657      IF( sdjf%num /= 0 )   CALL iom_close( sdjf%num )   ! close file if already open 
    … …  
    693680      !! 
    694681      !! ** Purpose :   fill sdf with sdf_n and control print 
    695       !! 
    696       !! ** Method  :    
    697682      !!---------------------------------------------------------------------- 
    698683      TYPE(FLD)  , DIMENSION(:), INTENT(inout) ::   sdf        ! structure of input fields (file informations, fields read) 
    … …  
    748733      !!                if it is a new entry, the weights data is read in and 
    749734      !!                restructured (fld_weight) 
    750       !! 
    751       !! ** Method  :    
    752       !!---------------------------------------------------------------------- 
    753       TYPE( FLD ),      INTENT(in)    ::   sd        ! field with name of weights file 
    754       INTEGER,      INTENT(inout)     ::   kwgt      ! index of weights 
    755       !! 
    756       INTEGER                         ::   kw 
    757       INTEGER                         ::   nestid 
    758       LOGICAL                         ::   found 
     735      !!---------------------------------------------------------------------- 
     736      TYPE( FLD ), INTENT(in   ) ::   sd        ! field with name of weights file 
     737      INTEGER    , INTENT(inout) ::   kwgt      ! index of weights 
     738      !! 
     739      INTEGER ::   kw, nestid   ! local integer 
     740      LOGICAL ::   found        ! local logical 
    759741      !!---------------------------------------------------------------------- 
    760742      ! 
    … …  
    782764         CALL fld_weight( sd ) 
    783765      ENDIF 
    784  
     766      ! 
    785767   END SUBROUTINE wgt_list 
    786768 
     769 
    787770   SUBROUTINE wgt_print( ) 
    788771      !!--------------------------------------------------------------------- 
    … …  
    790773      !! 
    791774      !! ** Purpose :   print the list of known weights 
    792       !! 
    793       !! ** Method  :    
    794       !!---------------------------------------------------------------------- 
    795       !! 
    796       INTEGER                         ::   kw 
    797       !!---------------------------------------------------------------------- 
    798       ! 
    799  
     775      !!---------------------------------------------------------------------- 
     776      INTEGER ::   kw   ! 
     777      !!---------------------------------------------------------------------- 
     778      ! 
    800779      DO kw = 1, nxt_wgt-1 
    801780         WRITE(numout,*) 'weight file:  ',TRIM(ref_wgts(kw)%wgtname) 
    … …  
    814793         IF( ASSOCIATED(ref_wgts(kw)%data_wgt) )  WRITE(numout,*) '       allocated' 
    815794      END DO 
    816  
     795      ! 
    817796   END SUBROUTINE wgt_print 
     797 
    818798 
    819799   SUBROUTINE fld_weight( sd ) 
    … …  
    823803      !! ** Purpose :   create a new WGT structure and fill in data from   
    824804      !!                file, restructuring as required 
    825       !! 
    826       !! ** Method  :    
    827805      !!---------------------------------------------------------------------- 
    828806      USE wrk_nemo, ONLY: wrk_use, wrk_release, iwrk_use, iwrk_release 
    … …  
    830808      USE wrk_nemo, ONLY: data_src => iwrk_2d_1 
    831809      !! 
    832       TYPE( FLD ),      INTENT(in)            ::   sd            ! field with name of weights file 
    833       !! 
    834       INTEGER                                 ::   jn            ! dummy loop indices 
    835       INTEGER                                 ::   inum          ! temporary logical unit 
    836       INTEGER                                 ::   id            ! temporary variable id 
    837       INTEGER                                 ::   ipk           ! temporary vertical dimension 
    838       CHARACTER (len=5)                       ::   aname 
    839       INTEGER , DIMENSION(3)                  ::   ddims 
    840       LOGICAL                                 ::   cyclical 
    841       INTEGER                                 ::   zwrap         ! temporary integer 
    842       !!---------------------------------------------------------------------- 
    843       ! 
    844       IF( (.NOT. wrk_use(2, 1)) .OR. (.NOT. iwrk_use(2,1)) )THEN 
    845          CALL ctl_stop('fld_weights: requested workspace arrays are unavailable.') 
    846          RETURN 
     810      TYPE( FLD ), INTENT(in) ::   sd   ! field with name of weights file 
     811      !! 
     812      INTEGER                ::   jn            ! dummy loop indices 
     813      INTEGER                ::   inum          ! temporary logical unit 
     814      INTEGER                ::   id            ! temporary variable id 
     815      INTEGER                ::   ipk           ! temporary vertical dimension 
     816      CHARACTER (len=5)      ::   aname 
     817      INTEGER , DIMENSION(3) ::   ddims 
     818      LOGICAL                ::   cyclical 
     819      INTEGER                ::   zwrap      ! local integer 
     820      !!---------------------------------------------------------------------- 
     821      ! 
     822      IF(  .NOT. wrk_use(2, 1)  .OR.  .NOT. iwrk_use(2,1)  ) THEN 
     823         CALL ctl_stop('fld_weights: requested workspace arrays are unavailable.')   ;   RETURN 
    847824      END IF 
    848825      ! 
    … …  
    957934      ENDIF 
    958935 
    959       IF( (.NOT. wrk_release(2, 1)) .OR. (.NOT. iwrk_release(2,1)) )THEN 
    960          CALL ctl_stop('fld_weights: failed to release workspace arrays.') 
    961       END IF 
    962  
     936      IF( .NOT. wrk_release(2, 1) .OR.    & 
     937          .NOT.iwrk_release(2, 1)   )   CALL ctl_stop('fld_weights: failed to release workspace arrays') 
     938      ! 
    963939   END SUBROUTINE fld_weight 
    964940 
    965    SUBROUTINE fld_interp(num, clvar, kw, kk, dta, nrec) 
     941 
     942   SUBROUTINE fld_interp( num, clvar, kw, kk, dta, nrec ) 
    966943      !!--------------------------------------------------------------------- 
    967944      !!                    ***  ROUTINE fld_interp  *** 
    … …  
    969946      !! ** Purpose :   apply weights to input gridded data to create data 
    970947      !!                on model grid 
    971       !! 
    972       !! ** Method  :    
    973       !!---------------------------------------------------------------------- 
    974       INTEGER,          INTENT(in)                        ::   num                 ! stream number 
    975       CHARACTER(LEN=*), INTENT(in)                        ::   clvar               ! variable name 
    976       INTEGER,          INTENT(in)                        ::   kw                  ! weights number 
    977       INTEGER,          INTENT(in)                        ::   kk                  ! vertical dimension of kk 
    978       REAL(wp),         INTENT(inout), DIMENSION(:,:,:)   ::   dta              ! output field on model grid 
    979       INTEGER,          INTENT(in)                        ::   nrec                ! record number to read (ie time slice) 
     948      !!---------------------------------------------------------------------- 
     949      INTEGER                   , INTENT(in   ) ::   num     ! stream number 
     950      CHARACTER(LEN=*)          , INTENT(in   ) ::   clvar   ! variable name 
     951      INTEGER                   , INTENT(in   ) ::   kw      ! weights number 
     952      INTEGER                   , INTENT(in   ) ::   kk      ! vertical dimension of kk 
     953      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   dta     ! output field on model grid 
     954      INTEGER                   , INTENT(in   ) ::   nrec    ! record number to read (ie time slice) 
    980955      !!  
    981       INTEGER, DIMENSION(3)                               ::   rec1,recn           ! temporary arrays for start and length 
    982       INTEGER                                             ::  jk, jn, jm           ! loop counters 
    983       INTEGER                                             ::  ni, nj               ! lengths 
    984       INTEGER                                             ::  jpimin,jpiwid        ! temporary indices 
    985       INTEGER                                             ::  jpjmin,jpjwid        ! temporary indices 
    986       INTEGER                                             ::  jpi1,jpi2,jpj1,jpj2  ! temporary indices 
    987       !!---------------------------------------------------------------------- 
    988       ! 
    989  
     956      INTEGER, DIMENSION(3) ::   rec1,recn   ! temporary arrays for start and length 
     957      INTEGER ::  jk, jn, jm           ! loop counters 
     958      INTEGER ::  ni, nj               ! lengths 
     959      INTEGER ::  jpimin,jpiwid        ! temporary indices 
     960      INTEGER ::  jpjmin,jpjwid        ! temporary indices 
     961      INTEGER ::  jpi1,jpi2,jpj1,jpj2  ! temporary indices 
     962      !!---------------------------------------------------------------------- 
     963      ! 
    990964      !! for weighted interpolation we have weights at four corners of a box surrounding  
    991965      !! a model grid point, each weight is multiplied by a grid value (bilinear case) 
    … …  
    11071081        END DO 
    11081082 
    1109         ! gradient in the ij direction 
    1110         DO jk = 1,4 
    1111           DO jn = 1, jpj 
    1112             DO jm = 1,jpi 
    1113               ni = ref_wgts(kw)%data_jpi(jm,jn,jk) 
    1114               nj = ref_wgts(kw)%data_jpj(jm,jn,jk) 
    1115               dta(jm,jn,:) = dta(jm,jn,:) + ref_wgts(kw)%data_wgt(jm,jn,jk+12) * 0.25 * ( & 
     1083         ! gradient in the ij direction 
     1084         DO jk = 1,4 
     1085            DO jn = 1, jpj 
     1086               DO jm = 1,jpi 
     1087                  ni = ref_wgts(kw)%data_jpi(jm,jn,jk) 
     1088                  nj = ref_wgts(kw)%data_jpj(jm,jn,jk) 
     1089                  dta(jm,jn,:) = dta(jm,jn,:) + ref_wgts(kw)%data_wgt(jm,jn,jk+12) * 0.25 * ( & 
    11161090                               (ref_wgts(kw)%fly_dta(ni+2,nj+2,:) - ref_wgts(kw)%fly_dta(ni  ,nj+2,:)) -   & 
    11171091                               (ref_wgts(kw)%fly_dta(ni+2,nj  ,:) - ref_wgts(kw)%fly_dta(ni  ,nj  ,:))) 
     1092               END DO 
    11181093            END DO 
    1119           END DO 
    1120         END DO 
    1121  
     1094         END DO 
     1095         ! 
    11221096      END IF 
    1123  
     1097      ! 
    11241098   END SUBROUTINE fld_interp 
    11251099 
    … …  
    11301104      !! 
    11311105      !! ** Purpose :   
    1132       !! 
    1133       !! ** Method  : 
    11341106      !!--------------------------------------------------------------------- 
    11351107      CHARACTER(len=*), INTENT(in)   ::   cdday   !3 first letters of the first day of the weekly file 
    … …  
    11431115      DO ijul = 1, 7 
    11441116         IF( cl_week(ijul) == TRIM(cdday) ) EXIT 
    1145       ENDDO 
     1117      END DO 
    11461118      IF( ijul .GT. 7 )   CALL ctl_stop( 'ksec_week: wrong day for sdjf%cltype(6:8): '//TRIM(cdday) ) 
    11471119      ! 
    … …  
    11531125   END FUNCTION ksec_week 
    11541126 
    1155  
     1127   !!====================================================================== 
    11561128END MODULE fldread 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/SBC/geo2ocean.F90

    r2590 r2620  
    44   !! Ocean mesh    :  ??? 
    55   !!====================================================================== 
    6    !! History :  OPA  !  07-1996  (O. Marti)  Original code 
    7    !!   NEMO     1.0  !  02-2008  (G. Madec)  F90: Free form 
    8    !!            3.0  !   
     6   !! History :  OPA  ! 1989-07  (O. Marti)  Original code 
     7   !!   NEMO     1.0  ! 2002-08  (G. Madec)  F90: Free form + opt. 
     8   !!             -   ! 2006-02  (A. Caubel)  oce2geo - Original code 
     9   !!            2.0  ! 2007-04  (S. Masson)  Add T, F points and bugfix in cos lateral boundary 
     10   !!            3.0  ! 2008-07  (G. Madec)  geo2oce suppress lon/lat agruments 
     11   !!            3.3  ! 2010-10  (K. Mogensen) add obs_rot 
     12   !!            4.0  ! 2011-02  (G. Madec)  dynamical allocation + addition of angle_geo 
    913   !!---------------------------------------------------------------------- 
    1014 
    1115   !!---------------------------------------------------------------------- 
    12    !!   repcmo      :  
    13    !!   angle       : 
    14    !!   geo2oce     : 
    15    !!   repere      :   old routine suppress it ??? 
     16   !!   angle_msh_geo    : local sin/cos of the angle between model grid lines and the North direction 
     17   !!   angle_geo        : local sin/cos of the latitude and longitude at each mesh grid point 
     18   !!   geo2oce, oce2geo : ? 
     19   !!   obs_rot          : provide to OBS operator the sin &cos at u- and v-points 
     20   !! 
     21   !!   repcmo, repere, rot_rep :   old routines  ==> to be suppressed 
    1622   !!---------------------------------------------------------------------- 
    17    USE dom_oce         ! mesh and scale factors 
    18    USE phycst          ! physical constants 
    19    USE in_out_manager  ! I/O manager 
    20    USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
     23   USE dom_oce        ! mesh and scale factors 
     24   USE phycst         ! physical constants 
     25   USE in_out_manager ! I/O manager 
     26   USE lbclnk         ! ocean lateral boundary conditions (or mpp link) 
    2127 
    2228   IMPLICIT NONE 
    2329   PRIVATE 
    2430 
    25    PUBLIC   rot_rep, repcmo, repere, geo2oce, oce2geo   ! only rot_rep should be used 
    26                                              ! repcmo and repere are keep only for compatibility. 
    27                                              ! they are only a useless overlay of rot_rep 
    28  
    29    PUBLIC   obs_rot 
    30    PUBLIC   geo2oce_alloc ! Called in nemogcm.F90 
    31  
    32    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   & 
    33       gsint, gcost,   &  ! cos/sin between model grid lines and NP direction at T point 
    34       gsinu, gcosu,   &  ! cos/sin between model grid lines and NP direction at U point 
    35       gsinv, gcosv,   &  ! cos/sin between model grid lines and NP direction at V point 
    36       gsinf, gcosf       ! cos/sin between model grid lines and NP direction at F point 
    37  
    38    LOGICAL ::   lmust_init = .TRUE.        !: used to initialize the cos/sin variables (se above) 
    39  
    40    ! Local 'saved' arrays - one set for geo2oce and one set for oce2geo. 
    41    ! Declared here so can be allocated in ge2oce_alloc(). 
    42    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   zsinlon_o2g, zcoslon_o2g, zsinlat_o2g, zcoslat_o2g 
    43    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   zsinlon_g2o, zcoslon_g2o, zsinlat_g2o, zcoslat_g2o 
     31   PUBLIC   geo2oce, oce2geo   !     
     32   PUBLIC   obs_rot            ! 
     33   ! 
     34   PUBLIC   repcmo, repere, rot_rep    ! CAUTION: these routines are kept only for compatibility. 
     35   !                                   !          They are only a useless overlay of rot_rep 
     36 
     37   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   gsin, gcos         ! sinus & cosinus at T,U,V,F points 
     38   !                                                                     ! between mesh and NP direction 
     39   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   gsinlon, gsinlat   ! sinus   of lon & lat at T,U,V,F points 
     40   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   gcoslon, gcoslat   ! cosinus of lon & lat at T,U,V,F points 
    4441 
    4542   !! * Substitutions 
    4643#  include "vectopt_loop_substitute.h90" 
    4744   !!---------------------------------------------------------------------- 
    48    !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
     45   !! NEMO/OPA 4.0 , NEMO Consortium (2011) 
    4946   !! $Id$  
    50    !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
     47   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    5148   !!---------------------------------------------------------------------- 
    52  
    5349CONTAINS 
    5450 
    55    FUNCTION geo2oce_alloc() 
    56       !!---------------------------------------------------------------------- 
    57       !!                  ***  ROUTINE geo2oce_alloc  *** 
    58       !!---------------------------------------------------------------------- 
    59       IMPLICIT none 
    60       INTEGER :: geo2oce_alloc 
    61  
    62       ALLOCATE(gsint(jpi,jpj), gcost(jpi,jpj),   & 
    63                gsinu(jpi,jpj), gcosu(jpi,jpj),   & 
    64                gsinv(jpi,jpj), gcosv(jpi,jpj),   & 
    65                gsinf(jpi,jpj), gcosf(jpi,jpj),   & 
    66                ! 
    67                zsinlon_o2g(jpi,jpj,4), zcoslon_o2g(jpi,jpj,4), &  
    68                zsinlat_o2g(jpi,jpj,4), zcoslat_o2g(jpi,jpj,4), & 
    69                zsinlon_g2o(jpi,jpj,4), zcoslon_g2o(jpi,jpj,4), & 
    70                zsinlat_g2o(jpi,jpj,4), zcoslat_g2o(jpi,jpj,4), & 
    71                Stat=geo2oce_alloc) 
    72  
    73    END FUNCTION geo2oce_alloc 
    74  
    75  
    76    SUBROUTINE repcmo ( pxu1, pyu1, pxv1, pyv1,   & 
    77                        px2 , py2 ) 
     51   SUBROUTINE angle_msh_geo 
     52      !!---------------------------------------------------------------------- 
     53      !!                  ***  ROUTINE angle_msh_geo  *** 
     54      !!  
     55      !! ** Purpose :   Compute angles between model grid lines and the North direction 
     56      !! 
     57      !! ** Action  :   allocate and compute (gsint, gcost, gsinu, gcosu, gsinv,  
     58      !!              gcosv, gsinf, gcosf) arrays: sinus and cosinus of the angle  
     59      !!              between the north-south axe and the j-direction at t, u, v and f-points 
     60      !!---------------------------------------------------------------------- 
     61      INTEGER  ::   ji, jj   ! dummy loop indices 
     62      INTEGER  ::   ierr     ! local integer 
     63      REAL(wp) ::   zpi_4    ! local scalar (pi/4) 
     64      REAL(wp) ::   zlam, zphi, zlan, zphh   ! local scalars 
     65      REAL(wp) ::   zxnpt, zynpt, znnpt      ! x,y components & norm of the vector: T point to North Pole 
     66      REAL(wp) ::   zxnpu, zynpu, znnpu      ! x,y components & norm of the vector: U point to North Pole 
     67      REAL(wp) ::   zxnpv, zynpv, znnpv      ! x,y components & norm of the vector: V point to North Pole 
     68      REAL(wp) ::   zxnpf, zynpf, znnpf      ! x,y components & norm of the vector: F point to North Pole 
     69      REAL(wp) ::   zxvvt, zyvvt, znvvt      ! x,y components & norm of the vector: between V pts below and above a T pt 
     70      REAL(wp) ::   zxffu, zyffu, znffu      ! x,y components & norm of the vector: between F pts below and above a U pt 
     71      REAL(wp) ::   zxffv, zyffv, znffv      ! x,y components & norm of the vector: between F pts left  and right a V pt 
     72      REAL(wp) ::   zxuuf, zyuuf, znuuf      ! x,y components & norm of the vector: between U pts below and above a F pt 
     73      !!---------------------------------------------------------------------- 
     74      ! 
     75      ! already allocated & initialized  ==> return 
     76      ! ------------------------------- 
     77      IF( ALLOCATED( gsin ) .AND. ALLOCATED( gcos )  )   RETURN 
     78 
     79      ! allocate cos & sin arrays  
     80      ! ------------------------- 
     81      ALLOCATE( gsin(jpi,jpj,4) , gcos(jpi,jpj,4) , STAT=ierr ) 
     82      IF(lk_mpp)   CALL mpp_sum( ierr ) 
     83      IF( ierr /= 0 )   CALL ctl_stop('STOP', 'angle_msh_geo: unable to allocate arrays' ) 
     84      ! 
     85      ! initialize cos & sin arrays 
     86      ! ---------------------------- 
     87      ! (computation done on the north stereographic polar plane) 
     88      IF(lwp) WRITE(numout,*) 
     89      IF(lwp) WRITE(numout,*) ' angle_msh_geo : geographic <--> model mesh , cos/sin initialization ' 
     90      IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~~' 
     91 
     92      zpi_4 = rpi / 4._wp 
     93      ! 
     94      DO jj = 2, jpjm1 
     95!CDIR NOVERRCHK 
     96         DO ji = fs_2, jpi   ! vector opt. 
     97            ! 
     98            zlam = glamt(ji,jj)            ! north pole direction & modulous (at t-point) 
     99            zphi = gphit(ji,jj) 
     100            zxnpt = 0._wp - 2._wp * COS( rad*zlam ) * TAN( zpi_4 - rad*zphi*0.5 ) 
     101            zynpt = 0._wp - 2._wp * SIN( rad*zlam ) * TAN( zpi_4 - rad*zphi*0.5 ) 
     102            znnpt = zxnpt*zxnpt + zynpt*zynpt 
     103 
     104            zlam = glamu(ji,jj)            ! north pole direction & modulous (at u-point) 
     105            zphi = gphiu(ji,jj) 
     106            zxnpu = 0._wp - 2._wp * COS( rad*zlam ) * TAN( zpi_4 - rad*zphi*0.5 ) 
     107            zynpu = 0._wp - 2._wp * SIN( rad*zlam ) * TAN( zpi_4 - rad*zphi*0.5 ) 
     108            znnpu = zxnpu*zxnpu + zynpu*zynpu 
     109 
     110            zlam = glamv(ji,jj)            ! north pole direction & modulous (at v-point) 
     111            zphi = gphiv(ji,jj) 
     112            zxnpv = 0._wp - 2._wp * COS( rad*zlam ) * TAN( zpi_4 - rad*zphi*0.5 ) 
     113            zynpv = 0._wp - 2._wp * SIN( rad*zlam ) * TAN( zpi_4 - rad*zphi*0.5 ) 
     114            znnpv = zxnpv*zxnpv + zynpv*zynpv 
     115             
     116            zlam = glamf(ji,jj)            ! north pole direction & modulous (at f-point) 
     117            zphi = gphif(ji,jj) 
     118            zxnpf = 0._wp - 2._wp * COS( rad*zlam ) * TAN( zpi_4 - rad*zphi*0.5 ) 
     119            zynpf = 0._wp - 2._wp * SIN( rad*zlam ) * TAN( zpi_4 - rad*zphi*0.5 ) 
     120            znnpf = zxnpf*zxnpf + zynpf*zynpf 
     121 
     122            zlam = glamv(ji,jj  )            ! j-direction: v-point segment direction (around t-point) 
     123            zphi = gphiv(ji,jj  ) 
     124            zlan = glamv(ji,jj-1) 
     125            zphh = gphiv(ji,jj-1) 
     126            zxvvt =  2._wp * COS( rad*zlam ) * TAN( zpi_4 - rad*zphi*0.5 )   & 
     127               &  -  2._wp * COS( rad*zlan ) * TAN( zpi_4 - rad*zphh*0.5 ) 
     128            zyvvt =  2._wp * SIN( rad*zlam ) * TAN( zpi_4 - rad*zphi*0.5 )   & 
     129               &  -  2._wp * SIN( rad*zlan ) * TAN( zpi_4 - rad*zphh*0.5 ) 
     130            znvvt = SQRT( znnpt * ( zxvvt*zxvvt + zyvvt*zyvvt )  ) 
     131            znvvt = MAX( znvvt, 1.e-14 ) 
     132 
     133            zlam = glamf(ji,jj  )            ! j-direction: f-point segment direction (around u-point) 
     134            zphi = gphif(ji,jj  ) 
     135            zlan = glamf(ji,jj-1) 
     136            zphh = gphif(ji,jj-1) 
     137            zxffu =  2._wp * COS( rad*zlam ) * TAN( zpi_4 - rad*zphi*0.5 )   & 
     138               &  -  2._wp * COS( rad*zlan ) * TAN( zpi_4 - rad*zphh*0.5 ) 
     139            zyffu =  2._wp * SIN( rad*zlam ) * TAN( zpi_4 - rad*zphi*0.5 )   & 
     140               &  -  2._wp * SIN( rad*zlan ) * TAN( zpi_4 - rad*zphh*0.5 ) 
     141            znffu = SQRT( znnpu * ( zxffu*zxffu + zyffu*zyffu )  ) 
     142            znffu = MAX( znffu, 1.e-14 ) 
     143 
     144            zlam = glamf(ji  ,jj)            ! i-direction: f-point segment direction (around v-point) 
     145            zphi = gphif(ji  ,jj) 
     146            zlan = glamf(ji-1,jj) 
     147            zphh = gphif(ji-1,jj) 
     148            zxffv =  2._wp * COS( rad*zlam ) * TAN( zpi_4 - rad*zphi*0.5 )   & 
     149               &  -  2._wp * COS( rad*zlan ) * TAN( zpi_4 - rad*zphh*0.5 ) 
     150            zyffv =  2._wp * SIN( rad*zlam ) * TAN( zpi_4 - rad*zphi*0.5 )   & 
     151               &  -  2._wp * SIN( rad*zlan ) * TAN( zpi_4 - rad*zphh*0.5 ) 
     152            znffv = SQRT( znnpv * ( zxffv*zxffv + zyffv*zyffv )  ) 
     153            znffv = MAX( znffv, 1.e-14 ) 
     154 
     155            zlam = glamu(ji,jj+1)            ! j-direction: u-point segment direction (around f-point) 
     156            zphi = gphiu(ji,jj+1) 
     157            zlan = glamu(ji,jj  ) 
     158            zphh = gphiu(ji,jj  ) 
     159            zxuuf =  2._wp * COS( rad*zlam ) * TAN( zpi_4 - rad*zphi*0.5 )   & 
     160               &  -  2._wp * COS( rad*zlan ) * TAN( zpi_4 - rad*zphh*0.5 ) 
     161            zyuuf =  2._wp * SIN( rad*zlam ) * TAN( zpi_4 - rad*zphi*0.5 )   & 
     162               &  -  2._wp * SIN( rad*zlan ) * TAN( zpi_4 - rad*zphh*0.5 ) 
     163            znuuf = SQRT( znnpf * ( zxuuf*zxuuf + zyuuf*zyuuf )  ) 
     164            znuuf = MAX( znuuf, 1.e-14 ) 
     165 
     166            ! cosinus and sinus using scalar and vectorial products 
     167            gsin(ji,jj,1) = ( zxnpt*zyvvt - zynpt*zxvvt ) / znvvt      ! T-point 
     168            gcos(ji,jj,1) = ( zxnpt*zxvvt + zynpt*zyvvt ) / znvvt 
     169 
     170            gsin(ji,jj,2) = ( zxnpu*zyffu - zynpu*zxffu ) / znffu      ! U-point 
     171            gcos(ji,jj,2) = ( zxnpu*zxffu + zynpu*zyffu ) / znffu 
     172            ! 
     173            gsin(ji,jj,3) = ( zxnpv*zxffv + zynpv*zyffv ) / znffv        ! F-point 
     174            gcos(ji,jj,3) =-( zxnpv*zyffv - zynpv*zxffv ) / znffv            ! (caution, rotation of 90 degres) 
     175            ! 
     176            gsin(ji,jj,4) = ( zxnpf*zyuuf - zynpf*zxuuf ) / znuuf      ! V-point 
     177            gcos(ji,jj,4) = ( zxnpf*zxuuf + zynpf*zyuuf ) / znuuf 
     178            ! 
     179         END DO 
     180      END DO 
     181      ! 
     182      ! Geographic mesh case 
     183      ! -------------------- 
     184      DO jj = 2, jpjm1 
     185         DO ji = fs_2, jpi   ! vector opt. 
     186            IF( MOD( ABS( glamv(ji,jj) - glamv(ji,jj-1) ), 360. ) < 1.e-8 ) THEN 
     187               gsin(ji,jj,1) = 0. 
     188               gcos(ji,jj,1) = 1. 
     189            ENDIF 
     190            IF( MOD( ABS( glamf(ji,jj) - glamf(ji,jj-1) ), 360. ) < 1.e-8 ) THEN 
     191               gsin(ji,jj,2) = 0. 
     192               gcos(ji,jj,2) = 1. 
     193            ENDIF 
     194            IF(      ABS( gphif(ji,jj) - gphif(ji-1,jj) )         < 1.e-8 ) THEN 
     195               gsin(ji,jj,3) = 0. 
     196               gcos(ji,jj,3) = 1. 
     197            ENDIF 
     198            IF( MOD( ABS( glamu(ji,jj) - glamu(ji,jj+1) ), 360. ) < 1.e-8 ) THEN 
     199               gsin(ji,jj,4) = 0. 
     200               gcos(ji,jj,4) = 1. 
     201            ENDIF 
     202         END DO 
     203      END DO 
     204      ! 
     205      CALL lbc_lnk( gcos(:,:,1), 'T', -1. )   ;   CALL lbc_lnk( gsin(:,:,1), 'T', -1. )      ! lateral boundary cond. 
     206      CALL lbc_lnk( gcos(:,:,2), 'U', -1. )   ;   CALL lbc_lnk( gsin(:,:,2), 'U', -1. ) 
     207      CALL lbc_lnk( gcos(:,:,3), 'V', -1. )   ;   CALL lbc_lnk( gsin(:,:,3), 'V', -1. ) 
     208      CALL lbc_lnk( gcos(:,:,4), 'F', -1. )   ;   CALL lbc_lnk( gsin(:,:,4), 'F', -1. ) 
     209      ! 
     210   END SUBROUTINE angle_msh_geo 
     211 
     212 
     213   SUBROUTINE angle_geo 
     214      !!---------------------------------------------------------------------- 
     215      !!                    ***  ROUTINE angle_geo  *** 
     216      !!       
     217      !! ** Purpose :   compute one for all, and at each mesh grid points,  
     218      !!              the local cos/sin of latitude/longitude. 
     219      !!---------------------------------------------------------------------- 
     220      INTEGER ierr 
     221      !!---------------------------------------------------------------------- 
     222      ! 
     223      IF( ALLOCATED( gsinlon ) .AND. ALLOCATED( gcoslon ) .AND.   &   !==  already allocated & initialized 
     224          ALLOCATED( gsinlat ) .AND. ALLOCATED( gcoslat )         )   RETURN 
     225 
     226      ALLOCATE( gsinlon(jpi,jpj,4) , gcoslon(jpi,jpj,4) ,     &       !==  allocate the arrays 
     227         &      gsinlat(jpi,jpj,4) , gcoslat(jpi,jpj,4) , STAT=ierr ) 
     228      IF( lk_mpp    )   CALL mpp_sum( ierr ) 
     229      IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'angle_geo: unable to allocate arrays') 
     230         ! 
     231      gsinlon(:,:,1) = SIN( rad * glamt(:,:) )     ! T-point 
     232      gcoslon(:,:,1) = COS( rad * glamt(:,:) ) 
     233      gsinlat(:,:,1) = SIN( rad * gphit(:,:) ) 
     234      gcoslat(:,:,1) = COS( rad * gphit(:,:) ) 
     235      ! 
     236      gsinlon(:,:,2) = SIN( rad * glamu(:,:) )     ! U-point 
     237      gcoslon(:,:,2) = COS( rad * glamu(:,:) ) 
     238      gsinlat(:,:,2) = SIN( rad * gphiu(:,:) ) 
     239      gcoslat(:,:,2) = COS( rad * gphiu(:,:) ) 
     240      ! 
     241      gsinlon(:,:,3) = SIN( rad * glamv(:,:) )     ! V-point 
     242      gcoslon(:,:,3) = COS( rad * glamv(:,:) ) 
     243      gsinlat(:,:,3) = SIN( rad * gphiv(:,:) ) 
     244      gcoslat(:,:,3) = COS( rad * gphiv(:,:) ) 
     245      ! 
     246      gsinlon(:,:,4) = SIN( rad * glamf(:,:) )     ! T-point 
     247      gcoslon(:,:,4) = COS( rad * glamf(:,:) ) 
     248      gsinlat(:,:,4) = SIN( rad * gphif(:,:) ) 
     249      gcoslat(:,:,4) = COS( rad * gphif(:,:) ) 
     250      ! 
     251   END SUBROUTINE angle_geo 
     252 
     253 
     254   SUBROUTINE geo2oce( pxx, pyy, pzz, cgrid, pte, ptn ) 
     255      !!---------------------------------------------------------------------- 
     256      !!                    ***  ROUTINE geo2oce  *** 
     257      !!       
     258      !! ** Purpose :   Change a vector from geocentric to east/north 
     259      !!---------------------------------------------------------------------- 
     260      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   pxx, pyy, pzz   ! 
     261      CHARACTER(len=1)            , INTENT(in   ) ::   cgrid           ! type of grid point 
     262      REAL(wp), DIMENSION(jpi,jpj), INTENT(  out) ::   pte, ptn        ! 
     263      !! 
     264      INTEGER ::   ipt     ! local integer 
     265      !!---------------------------------------------------------------------- 
     266 
     267      CALL angle_geo             ! initialization of coc & sin (just a return if not the 1st call) 
     268      ! 
     269      SELECT CASE (cgrid)        ! type of point 
     270      CASE ('T')   ;   ipt = 1 
     271      CASE ('U')   ;   ipt = 2 
     272      CASE ('V')   ;   ipt = 3 
     273      CASE ('F')   ;   ipt = 4 
     274      CASE DEFAULT   ;   CALL ctl_stop( 'Only T, U, V and F grid points are coded' ) 
     275      END SELECT 
     276   
     277      !                          ! transformation 
     278      pte(:,:) = - gsinlon(:,:,ipt)                    * pxx(:,:) + gcoslon(:,:,ipt) * pyy(:,:) 
     279      ptn(:,:) = - gsinlat(:,:,ipt) * gsinlat(:,:,ipt) * pxx(:,:)    & 
     280         &       - gsinlon(:,:,ipt) * gsinlat(:,:,ipt) * pyy(:,:) + gcoslat(:,:,ipt) * pzz(:,:) 
     281!!$   ptv(:,:) =   gsinlat(:,:,ipt) * gcoslat(:,:,ipt) * pxx(:,:)    & 
     282!!$              + zsinlon(:,:,ipt) * gcoslat(:,:,ipt) * pyy(:,:) + gsinlat(:,:,ipt) * pzz(:,:) 
     283      ! 
     284   END SUBROUTINE geo2oce 
     285 
     286 
     287   SUBROUTINE oce2geo ( pte, ptn, cgrid, pxx , pyy , pzz ) 
     288      !!---------------------------------------------------------------------- 
     289      !!                    ***  ROUTINE oce2geo  *** 
     290      !!       
     291      !! ** Purpose :   Change vector from east/north to geocentric 
     292      !!---------------------------------------------------------------------- 
     293      REAL(wp), DIMENSION(:,:), INTENT(in   ) ::  pte, ptn          !  
     294      CHARACTER(len=1)        , INTENT(in   ) ::  cgrid             ! 
     295      REAL(wp), DIMENSION(:,:), INTENT(  out) ::  pxx , pyy , pzz   ! 
     296      !! 
     297      INTEGER ::   ipt     ! 
     298      !!---------------------------------------------------------------------- 
     299      ! 
     300      CALL angle_geo             ! initialization of coc & sin (just a return if not the 1st call) 
     301      ! 
     302      SELECT CASE (cgrid)        ! type of point 
     303      CASE ('T')   ;   ipt = 1 
     304      CASE ('U')   ;   ipt = 2 
     305      CASE ('V')   ;   ipt = 3 
     306      CASE ('F')   ;   ipt = 4 
     307      CASE DEFAULT   ;   CALL ctl_stop( 'Only T, U, V and F grid points are coded' ) 
     308      END SELECT 
     309      ! 
     310      !                          ! transformation 
     311      pxx(:,:) = - gsinlon(:,:,ipt) * pte(:,:) - gcoslon(:,:,ipt) * gsinlat(:,:,ipt) * ptn(:,:)  
     312      pyy(:,:) =   gcoslon(:,:,ipt) * pte(:,:) - gsinlon(:,:,ipt) * gsinlat(:,:,ipt) * ptn(:,:) 
     313      pzz(:,:) =   gcoslat(:,:,ipt) * ptn(:,:) 
     314      ! 
     315   END SUBROUTINE oce2geo 
     316 
     317 
     318   SUBROUTINE obs_rot( psinu, pcosu, psinv, pcosv ) 
     319      !!---------------------------------------------------------------------- 
     320      !!                  ***  ROUTINE obs_rot  *** 
     321      !! 
     322      !! ** Purpose :   provide to OBS operator the sin &cos at u- and v-points 
     323      !!              in order to rotate currents at observation points 
     324      !!---------------------------------------------------------------------- 
     325      REAL(wp), DIMENSION(jpi,jpj), INTENT(out)::   psinu, pcosu, psinv, pcosv   ! copy of data 
     326      !!---------------------------------------------------------------------- 
     327      ! 
     328      CALL angle_msh_geo      ! initialization of coc & sin (just a return if not the 1st call) 
     329      ! 
     330      psinu(:,:) = gsin(:,:,2)      ! U-point 
     331      pcosu(:,:) = gcos(:,:,2) 
     332      psinv(:,:) = gsin(:,:,3)      ! V-point 
     333      pcosv(:,:) = gcos(:,:,3) 
     334      ! 
     335   END SUBROUTINE obs_rot 
     336 
     337 
     338   SUBROUTINE repcmo( pxu1, pyu1, pxv1, pyv1, px2 , py2 ) 
    78339      !!---------------------------------------------------------------------- 
    79340      !!                  ***  ROUTINE repcmo  *** 
    80341      !! 
    81342      !! ** Purpose :   Change vector componantes from a geographic grid to a 
    82       !!      stretched coordinates grid. 
     343      !!              stretched coordinates grid. 
    83344      !! 
    84345      !! ** Method  :   Initialization of arrays at the first call. 
    … …  
    92353      REAL(wp), INTENT(  out), DIMENSION(jpi,jpj) ::   py2          ! j-componante (defined at v-point) 
    93354      !!---------------------------------------------------------------------- 
    94        
    95       ! Change from geographic to stretched coordinate 
    96       ! ---------------------------------------------- 
    97       CALL rot_rep( pxu1, pyu1, 'U', 'en->i',px2 ) 
     355      !       
     356      CALL rot_rep( pxu1, pyu1, 'U', 'en->i',px2 )    ! Change from geographic to stretched coordinate 
    98357      CALL rot_rep( pxv1, pyv1, 'V', 'en->j',py2 ) 
    99        
     358      ! 
    100359   END SUBROUTINE repcmo 
    101360 
    102361 
    103    SUBROUTINE rot_rep ( pxin, pyin, cd_type, cdtodo, prot ) 
    104       !!---------------------------------------------------------------------- 
    105       !!                  ***  ROUTINE rot_rep  *** 
    106       !! 
    107       !! ** Purpose :   Rotate the Repere: Change vector componantes between 
    108       !!                geographic grid <--> stretched coordinates grid. 
    109       !! 
    110       !! History : 
    111       !!   9.2  !  07-04  (S. Masson)   
    112       !!                  (O. Marti ) Original code (repere and repcmo) 
    113       !!---------------------------------------------------------------------- 
    114       REAL(wp), DIMENSION(jpi,jpj), INTENT( IN ) ::   pxin, pyin   ! vector componantes 
    115       CHARACTER(len=1),             INTENT( IN ) ::   cd_type      ! define the nature of pt2d array grid-points 
    116       CHARACTER(len=5),             INTENT( IN ) ::   cdtodo       ! specify the work to do: 
    117       !!                                                           ! 'en->i' east-north componantes to model i componante 
    118       !!                                                           ! 'en->j' east-north componantes to model j componante 
    119       !!                                                           ! 'ij->e' model i-j componantes to east componante 
    120       !!                                                           ! 'ij->n' model i-j componantes to east componante 
    121       REAL(wp), DIMENSION(jpi,jpj), INTENT(out) ::   prot       
    122  
    123       !!---------------------------------------------------------------------- 
    124  
    125       ! Initialization of gsin* and gcos* at first call 
    126       ! ----------------------------------------------- 
    127  
    128       IF( lmust_init ) THEN 
    129          IF(lwp) WRITE(numout,*) 
    130          IF(lwp) WRITE(numout,*) ' rot_rep : geographic <--> stretched' 
    131          IF(lwp) WRITE(numout,*) ' ~~~~~    coordinate transformation' 
    132  
    133          CALL angle       ! initialization of the transformation 
    134          lmust_init = .FALSE. 
    135  
    136       ENDIF 
    137        
    138       SELECT CASE (cdtodo) 
    139       CASE ('en->i')      ! 'en->i' est-north componantes to model i componante 
    140          SELECT CASE (cd_type) 
    141          CASE ('T')   ;   prot(:,:) = pxin(:,:) * gcost(:,:) + pyin(:,:) * gsint(:,:) 
    142          CASE ('U')   ;   prot(:,:) = pxin(:,:) * gcosu(:,:) + pyin(:,:) * gsinu(:,:) 
    143          CASE ('V')   ;   prot(:,:) = pxin(:,:) * gcosv(:,:) + pyin(:,:) * gsinv(:,:) 
    144          CASE ('F')   ;   prot(:,:) = pxin(:,:) * gcosf(:,:) + pyin(:,:) * gsinf(:,:) 
    145          CASE DEFAULT   ;   CALL ctl_stop( 'Only T, U, V and F grid points are coded' ) 
    146          END SELECT 
    147       CASE ('en->j')      ! 'en->j' est-north componantes to model j componante 
    148          SELECT CASE (cd_type) 
    149          CASE ('T')   ;   prot(:,:) = pyin(:,:) * gcost(:,:) - pxin(:,:) * gsint(:,:) 
    150          CASE ('U')   ;   prot(:,:) = pyin(:,:) * gcosu(:,:) - pxin(:,:) * gsinu(:,:) 
    151          CASE ('V')   ;   prot(:,:) = pyin(:,:) * gcosv(:,:) - pxin(:,:) * gsinv(:,:)    
    152          CASE ('F')   ;   prot(:,:) = pyin(:,:) * gcosf(:,:) - pxin(:,:) * gsinf(:,:)    
    153          CASE DEFAULT   ;   CALL ctl_stop( 'Only T, U, V and F grid points are coded' ) 
    154          END SELECT 
    155       CASE ('ij->e')      ! 'ij->e' model i-j componantes to est componante 
    156          SELECT CASE (cd_type) 
    157          CASE ('T')   ;   prot(:,:) = pxin(:,:) * gcost(:,:) - pyin(:,:) * gsint(:,:) 
    158          CASE ('U')   ;   prot(:,:) = pxin(:,:) * gcosu(:,:) - pyin(:,:) * gsinu(:,:) 
    159          CASE ('V')   ;   prot(:,:) = pxin(:,:) * gcosv(:,:) - pyin(:,:) * gsinv(:,:) 
    160          CASE ('F')   ;   prot(:,:) = pxin(:,:) * gcosf(:,:) - pyin(:,:) * gsinf(:,:) 
    161          CASE DEFAULT   ;   CALL ctl_stop( 'Only T, U, V and F grid points are coded' ) 
    162          END SELECT 
    163       CASE ('ij->n')      ! 'ij->n' model i-j componantes to est componante 
    164          SELECT CASE (cd_type) 
    165          CASE ('T')   ;   prot(:,:) = pyin(:,:) * gcost(:,:) + pxin(:,:) * gsint(:,:) 
    166          CASE ('U')   ;   prot(:,:) = pyin(:,:) * gcosu(:,:) + pxin(:,:) * gsinu(:,:) 
    167          CASE ('V')   ;   prot(:,:) = pyin(:,:) * gcosv(:,:) + pxin(:,:) * gsinv(:,:) 
    168          CASE ('F')   ;   prot(:,:) = pyin(:,:) * gcosf(:,:) + pxin(:,:) * gsinf(:,:) 
    169          CASE DEFAULT   ;   CALL ctl_stop( 'Only T, U, V and F grid points are coded' ) 
    170          END SELECT 
    171       CASE DEFAULT   ;   CALL ctl_stop( 'rot_rep: Syntax Error in the definition of cdtodo' ) 
    172       END SELECT 
    173        
    174    END SUBROUTINE rot_rep 
    175  
    176  
    177    SUBROUTINE angle 
    178       !!---------------------------------------------------------------------- 
    179       !!                  ***  ROUTINE angle  *** 
    180       !!  
    181       !! ** Purpose :   Compute angles between model grid lines and the North direction 
    182       !! 
    183       !! ** Method  : 
    184       !! 
    185       !! ** Action  :   Compute (gsint, gcost, gsinu, gcosu, gsinv, gcosv, gsinf, gcosf) arrays: 
    186       !!      sinus and cosinus of the angle between the north-south axe and the  
    187       !!      j-direction at t, u, v and f-points 
    188       !! 
    189       !! History : 
    190       !!   7.0  !  96-07  (O. Marti )  Original code 
    191       !!   8.0  !  98-06  (G. Madec ) 
    192       !!   8.5  !  98-06  (G. Madec )  Free form, F90 + opt. 
    193       !!   9.2  !  07-04  (S. Masson)  Add T, F points and bugfix in cos lateral boundary 
    194       !!---------------------------------------------------------------------- 
    195       INTEGER ::   ji, jj      ! dummy loop indices 
    196       !! 
    197       REAL(wp) ::   & 
    198          zlam, zphi,            &  ! temporary scalars 
    199          zlan, zphh,            &  !    "         " 
    200          zxnpt, zynpt, znnpt,   &  ! x,y components and norm of the vector: T point to North Pole 
    201          zxnpu, zynpu, znnpu,   &  ! x,y components and norm of the vector: U point to North Pole 
    202          zxnpv, zynpv, znnpv,   &  ! x,y components and norm of the vector: V point to North Pole 
    203          zxnpf, zynpf, znnpf,   &  ! x,y components and norm of the vector: F point to North Pole 
    204          zxvvt, zyvvt, znvvt,   &  ! x,y components and norm of the vector: between V points below and above a T point 
    205          zxffu, zyffu, znffu,   &  ! x,y components and norm of the vector: between F points below and above a U point 
    206          zxffv, zyffv, znffv,   &  ! x,y components and norm of the vector: between F points left  and right a V point 
    207          zxuuf, zyuuf, znuuf       ! x,y components and norm of the vector: between U points below and above a F point 
    208       !!---------------------------------------------------------------------- 
    209  
    210       ! ============================= ! 
    211       ! Compute the cosinus and sinus ! 
    212       ! ============================= ! 
    213       ! (computation done on the north stereographic polar plane) 
    214  
    215       DO jj = 2, jpjm1 
    216 !CDIR NOVERRCHK 
    217          DO ji = fs_2, jpi   ! vector opt. 
    218  
    219             ! north pole direction & modulous (at t-point) 
    220             zlam = glamt(ji,jj) 
    221             zphi = gphit(ji,jj) 
    222             zxnpt = 0. - 2. * COS( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) 
    223             zynpt = 0. - 2. * SIN( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) 
    224             znnpt = zxnpt*zxnpt + zynpt*zynpt 
    225  
    226             ! north pole direction & modulous (at u-point) 
    227             zlam = glamu(ji,jj) 
    228             zphi = gphiu(ji,jj) 
    229             zxnpu = 0. - 2. * COS( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) 
    230             zynpu = 0. - 2. * SIN( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) 
    231             znnpu = zxnpu*zxnpu + zynpu*zynpu 
    232  
    233             ! north pole direction & modulous (at v-point) 
    234             zlam = glamv(ji,jj) 
    235             zphi = gphiv(ji,jj) 
    236             zxnpv = 0. - 2. * COS( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) 
    237             zynpv = 0. - 2. * SIN( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) 
    238             znnpv = zxnpv*zxnpv + zynpv*zynpv 
    239  
    240             ! north pole direction & modulous (at f-point) 
    241             zlam = glamf(ji,jj) 
    242             zphi = gphif(ji,jj) 
    243             zxnpf = 0. - 2. * COS( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) 
    244             zynpf = 0. - 2. * SIN( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) 
    245             znnpf = zxnpf*zxnpf + zynpf*zynpf 
    246  
    247             ! j-direction: v-point segment direction (around t-point) 
    248             zlam = glamv(ji,jj  ) 
    249             zphi = gphiv(ji,jj  ) 
    250             zlan = glamv(ji,jj-1) 
    251             zphh = gphiv(ji,jj-1) 
    252             zxvvt =  2. * COS( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. )   & 
    253                &  -  2. * COS( rad*zlan ) * TAN( rpi/4. - rad*zphh/2. ) 
    254             zyvvt =  2. * SIN( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. )   & 
    255                &  -  2. * SIN( rad*zlan ) * TAN( rpi/4. - rad*zphh/2. ) 
    256             znvvt = SQRT( znnpt * ( zxvvt*zxvvt + zyvvt*zyvvt )  ) 
    257             znvvt = MAX( znvvt, 1.e-14 ) 
    258  
    259             ! j-direction: f-point segment direction (around u-point) 
    260             zlam = glamf(ji,jj  ) 
    261             zphi = gphif(ji,jj  ) 
    262             zlan = glamf(ji,jj-1) 
    263             zphh = gphif(ji,jj-1) 
    264             zxffu =  2. * COS( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. )   & 
    265                &  -  2. * COS( rad*zlan ) * TAN( rpi/4. - rad*zphh/2. ) 
    266             zyffu =  2. * SIN( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. )   & 
    267                &  -  2. * SIN( rad*zlan ) * TAN( rpi/4. - rad*zphh/2. ) 
    268             znffu = SQRT( znnpu * ( zxffu*zxffu + zyffu*zyffu )  ) 
    269             znffu = MAX( znffu, 1.e-14 ) 
    270  
    271             ! i-direction: f-point segment direction (around v-point) 
    272             zlam = glamf(ji  ,jj) 
    273             zphi = gphif(ji  ,jj) 
    274             zlan = glamf(ji-1,jj) 
    275             zphh = gphif(ji-1,jj) 
    276             zxffv =  2. * COS( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. )   & 
    277                &  -  2. * COS( rad*zlan ) * TAN( rpi/4. - rad*zphh/2. ) 
    278             zyffv =  2. * SIN( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. )   & 
    279                &  -  2. * SIN( rad*zlan ) * TAN( rpi/4. - rad*zphh/2. ) 
    280             znffv = SQRT( znnpv * ( zxffv*zxffv + zyffv*zyffv )  ) 
    281             znffv = MAX( znffv, 1.e-14 ) 
    282  
    283             ! j-direction: u-point segment direction (around f-point) 
    284             zlam = glamu(ji,jj+1) 
    285             zphi = gphiu(ji,jj+1) 
    286             zlan = glamu(ji,jj  ) 
    287             zphh = gphiu(ji,jj  ) 
    288             zxuuf =  2. * COS( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. )   & 
    289                &  -  2. * COS( rad*zlan ) * TAN( rpi/4. - rad*zphh/2. ) 
    290             zyuuf =  2. * SIN( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. )   & 
    291                &  -  2. * SIN( rad*zlan ) * TAN( rpi/4. - rad*zphh/2. ) 
    292             znuuf = SQRT( znnpf * ( zxuuf*zxuuf + zyuuf*zyuuf )  ) 
    293             znuuf = MAX( znuuf, 1.e-14 ) 
    294  
    295             ! cosinus and sinus using scalar and vectorial products 
    296             gsint(ji,jj) = ( zxnpt*zyvvt - zynpt*zxvvt ) / znvvt 
    297             gcost(ji,jj) = ( zxnpt*zxvvt + zynpt*zyvvt ) / znvvt 
    298  
    299             gsinu(ji,jj) = ( zxnpu*zyffu - zynpu*zxffu ) / znffu 
    300             gcosu(ji,jj) = ( zxnpu*zxffu + zynpu*zyffu ) / znffu 
    301  
    302             gsinf(ji,jj) = ( zxnpf*zyuuf - zynpf*zxuuf ) / znuuf 
    303             gcosf(ji,jj) = ( zxnpf*zxuuf + zynpf*zyuuf ) / znuuf 
    304  
    305             ! (caution, rotation of 90 degres) 
    306             gsinv(ji,jj) = ( zxnpv*zxffv + zynpv*zyffv ) / znffv 
    307             gcosv(ji,jj) =-( zxnpv*zyffv - zynpv*zxffv ) / znffv 
    308  
    309          END DO 
    310       END DO 
    311  
    312       ! =============== ! 
    313       ! Geographic mesh ! 
    314       ! =============== ! 
    315  
    316       DO jj = 2, jpjm1 
    317          DO ji = fs_2, jpi   ! vector opt. 
    318             IF( MOD( ABS( glamv(ji,jj) - glamv(ji,jj-1) ), 360. ) < 1.e-8 ) THEN 
    319                gsint(ji,jj) = 0. 
    320                gcost(ji,jj) = 1. 
    321             ENDIF 
    322             IF( MOD( ABS( glamf(ji,jj) - glamf(ji,jj-1) ), 360. ) < 1.e-8 ) THEN 
    323                gsinu(ji,jj) = 0. 
    324                gcosu(ji,jj) = 1. 
    325             ENDIF 
    326             IF(      ABS( gphif(ji,jj) - gphif(ji-1,jj) )         < 1.e-8 ) THEN 
    327                gsinv(ji,jj) = 0. 
    328                gcosv(ji,jj) = 1. 
    329             ENDIF 
    330             IF( MOD( ABS( glamu(ji,jj) - glamu(ji,jj+1) ), 360. ) < 1.e-8 ) THEN 
    331                gsinf(ji,jj) = 0. 
    332                gcosf(ji,jj) = 1. 
    333             ENDIF 
    334          END DO 
    335       END DO 
    336  
    337       ! =========================== ! 
    338       ! Lateral boundary conditions ! 
    339       ! =========================== ! 
    340  
    341       ! lateral boundary cond.: T-, U-, V-, F-pts, sgn 
    342       CALL lbc_lnk( gcost, 'T', -1. )   ;   CALL lbc_lnk( gsint, 'T', -1. ) 
    343       CALL lbc_lnk( gcosu, 'U', -1. )   ;   CALL lbc_lnk( gsinu, 'U', -1. ) 
    344       CALL lbc_lnk( gcosv, 'V', -1. )   ;   CALL lbc_lnk( gsinv, 'V', -1. ) 
    345       CALL lbc_lnk( gcosf, 'F', -1. )   ;   CALL lbc_lnk( gsinf, 'F', -1. ) 
    346  
    347    END SUBROUTINE angle 
    348  
    349  
    350    SUBROUTINE geo2oce ( pxx, pyy, pzz, cgrid,     & 
    351                         pte, ptn ) 
    352       !!---------------------------------------------------------------------- 
    353       !!                    ***  ROUTINE geo2oce  *** 
    354       !!       
    355       !! ** Purpose : 
    356       !! 
    357       !! ** Method  :   Change wind stress from geocentric to east/north 
    358       !! 
    359       !! History : 
    360       !!        !         (O. Marti)  Original code 
    361       !!        !  91-03  (G. Madec) 
    362       !!        !  92-07  (M. Imbard) 
    363       !!        !  99-11  (M. Imbard) NetCDF format with IOIPSL 
    364       !!        !  00-08  (D. Ludicone) Reduced section at Bab el Mandeb 
    365       !!   8.5  !  02-06  (G. Madec)  F90: Free form 
    366       !!   3.0  !  07-08  (G. Madec)  geo2oce suppress lon/lat agruments 
    367       !!---------------------------------------------------------------------- 
    368       REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::  pxx, pyy, pzz 
    369       CHARACTER(len=1)            , INTENT(in   ) ::  cgrid 
    370       REAL(wp), DIMENSION(jpi,jpj), INTENT(  out) ::  pte, ptn 
    371       !! 
    372       REAL(wp), PARAMETER :: rpi = 3.141592653E0 
    373       REAL(wp), PARAMETER :: rad = rpi / 180.e0 
    374       INTEGER ::   ig     ! 
    375       !! * Local save 
    376       LOGICAL , SAVE, DIMENSION(4)         ::   linit = .FALSE. 
    377       !!---------------------------------------------------------------------- 
    378  
    379       SELECT CASE( cgrid) 
    380          CASE ( 'T' )    
    381             ig = 1 
    382             IF( .NOT. linit(ig) ) THEN  
    383                zsinlon_g2o(:,:,ig) = SIN( rad * glamt(:,:) ) 
    384                zcoslon_g2o(:,:,ig) = COS( rad * glamt(:,:) ) 
    385                zsinlat_g2o(:,:,ig) = SIN( rad * gphit(:,:) ) 
    386                zcoslat_g2o(:,:,ig) = COS( rad * gphit(:,:) ) 
    387                linit(ig) = .TRUE. 
    388             ENDIF 
    389          CASE ( 'U' )    
    390             ig = 2 
    391             IF( .NOT. linit(ig) ) THEN  
    392                zsinlon_g2o(:,:,ig) = SIN( rad * glamu(:,:) ) 
    393                zcoslon_g2o(:,:,ig) = COS( rad * glamu(:,:) ) 
    394                zsinlat_g2o(:,:,ig) = SIN( rad * gphiu(:,:) ) 
    395                zcoslat_g2o(:,:,ig) = COS( rad * gphiu(:,:) ) 
    396                linit(ig) = .TRUE. 
    397             ENDIF 
    398          CASE ( 'V' )    
    399             ig = 3 
    400             IF( .NOT. linit(ig) ) THEN  
    401                zsinlon_g2o(:,:,ig) = SIN( rad * glamv(:,:) ) 
    402                zcoslon_g2o(:,:,ig) = COS( rad * glamv(:,:) ) 
    403                zsinlat_g2o(:,:,ig) = SIN( rad * gphiv(:,:) ) 
    404                zcoslat_g2o(:,:,ig) = COS( rad * gphiv(:,:) ) 
    405                linit(ig) = .TRUE. 
    406             ENDIF 
    407          CASE ( 'F' )    
    408             ig = 4 
    409             IF( .NOT. linit(ig) ) THEN  
    410                zsinlon_g2o(:,:,ig) = SIN( rad * glamf(:,:) ) 
    411                zcoslon_g2o(:,:,ig) = COS( rad * glamf(:,:) ) 
    412                zsinlat_g2o(:,:,ig) = SIN( rad * gphif(:,:) ) 
    413                zcoslat_g2o(:,:,ig) = COS( rad * gphif(:,:) ) 
    414                linit(ig) = .TRUE. 
    415             ENDIF 
    416          CASE default    
    417             WRITE(ctmp1,*) 'geo2oce : bad grid argument : ', cgrid 
    418             CALL ctl_stop( ctmp1 ) 
    419       END SELECT 
    420        
    421       pte = - zsinlon_g2o(:,:,ig) * pxx + zcoslon_g2o(:,:,ig) * pyy 
    422       ptn = - zcoslon_g2o(:,:,ig) * zsinlat_g2o(:,:,ig) * pxx    & 
    423             - zsinlon_g2o(:,:,ig) * zsinlat_g2o(:,:,ig) * pyy    & 
    424             + zcoslat_g2o(:,:,ig) * pzz 
    425 !!$   ptv =   zcoslon(:,:,ig) * zcoslat(:,:,ig) * pxx    & 
    426 !!$         + zsinlon(:,:,ig) * zcoslat(:,:,ig) * pyy    & 
    427 !!$         + zsinlat(:,:,ig) * pzz 
    428       ! 
    429    END SUBROUTINE geo2oce 
    430  
    431    SUBROUTINE oce2geo ( pte, ptn, cgrid,     & 
    432                         pxx , pyy , pzz ) 
    433       !!---------------------------------------------------------------------- 
    434       !!                    ***  ROUTINE oce2geo  *** 
    435       !!       
    436       !! ** Purpose : 
    437       !! 
    438       !! ** Method  :   Change vector from east/north to geocentric 
    439       !! 
    440       !! History : 
    441       !!        !         (A. Caubel)  oce2geo - Original code 
    442       !!---------------------------------------------------------------------- 
    443       REAL(wp), DIMENSION(:,:), INTENT( IN    ) ::  pte, ptn 
    444       CHARACTER(len=1)        , INTENT( IN    ) ::  cgrid 
    445       REAL(wp), DIMENSION(:,:), INTENT(   OUT ) ::  pxx , pyy , pzz 
    446       !! 
    447       REAL(wp), PARAMETER :: rpi = 3.141592653E0 
    448       REAL(wp), PARAMETER :: rad = rpi / 180.e0 
    449       INTEGER ::   ig     ! 
    450       !! * Local save 
    451       LOGICAL , SAVE, DIMENSION(4)         ::   linit = .FALSE. 
    452       !!---------------------------------------------------------------------- 
    453  
    454       SELECT CASE( cgrid) 
    455          CASE ( 'T' )    
    456             ig = 1 
    457             IF( .NOT. linit(ig) ) THEN  
    458                zsinlon_o2g(:,:,ig) = SIN( rad * glamt(:,:) ) 
    459                zcoslon_o2g(:,:,ig) = COS( rad * glamt(:,:) ) 
    460                zsinlat_o2g(:,:,ig) = SIN( rad * gphit(:,:) ) 
    461                zcoslat_o2g(:,:,ig) = COS( rad * gphit(:,:) ) 
    462                linit(ig) = .TRUE. 
    463             ENDIF 
    464          CASE ( 'U' )    
    465             ig = 2 
    466             IF( .NOT. linit(ig) ) THEN  
    467                zsinlon_o2g(:,:,ig) = SIN( rad * glamu(:,:) ) 
    468                zcoslon_o2g(:,:,ig) = COS( rad * glamu(:,:) ) 
    469                zsinlat_o2g(:,:,ig) = SIN( rad * gphiu(:,:) ) 
    470                zcoslat_o2g(:,:,ig) = COS( rad * gphiu(:,:) ) 
    471                linit(ig) = .TRUE. 
    472             ENDIF 
    473          CASE ( 'V' )    
    474             ig = 3 
    475             IF( .NOT. linit(ig) ) THEN  
    476                zsinlon_o2g(:,:,ig) = SIN( rad * glamv(:,:) ) 
    477                zcoslon_o2g(:,:,ig) = COS( rad * glamv(:,:) ) 
    478                zsinlat_o2g(:,:,ig) = SIN( rad * gphiv(:,:) ) 
    479                zcoslat_o2g(:,:,ig) = COS( rad * gphiv(:,:) ) 
    480                linit(ig) = .TRUE. 
    481             ENDIF 
    482          CASE ( 'F' )    
    483             ig = 4 
    484             IF( .NOT. linit(ig) ) THEN  
    485                zsinlon_o2g(:,:,ig) = SIN( rad * glamf(:,:) ) 
    486                zcoslon_o2g(:,:,ig) = COS( rad * glamf(:,:) ) 
    487                zsinlat_o2g(:,:,ig) = SIN( rad * gphif(:,:) ) 
    488                zcoslat_o2g(:,:,ig) = COS( rad * gphif(:,:) ) 
    489                linit(ig) = .TRUE. 
    490             ENDIF 
    491          CASE default    
    492             WRITE(ctmp1,*) 'geo2oce : bad grid argument : ', cgrid 
    493             CALL ctl_stop( ctmp1 ) 
    494       END SELECT 
    495  
    496        pxx = - zsinlon_o2g(:,:,ig) * pte - zcoslon_o2g(:,:,ig) * zsinlat_o2g(:,:,ig) * ptn  
    497        pyy =   zcoslon_o2g(:,:,ig) * pte - zsinlon_o2g(:,:,ig) * zsinlat_o2g(:,:,ig) * ptn 
    498        pzz =   zcoslat_o2g(:,:,ig) * ptn 
    499  
    500        
    501    END SUBROUTINE oce2geo 
    502  
    503  
    504    SUBROUTINE repere ( px1, py1, px2, py2, kchoix, cd_type ) 
     362   SUBROUTINE repere( px1, py1, px2, py2, kchoix, cd_type ) 
    505363      !!---------------------------------------------------------------------- 
    506364      !!                 ***  ROUTINE repere  *** 
    507365      !!         
    508366      !! ** Purpose :   Change vector componantes between a geopgraphic grid  
    509       !!      and a stretched coordinates grid. 
    510       !! 
    511       !! ** Method  :    
    512       !! 
    513       !! ** Action  : 
    514       !! 
    515       !! History : 
    516       !!        !  89-03  (O. Marti)  original code 
    517       !!        !  92-02  (M. Imbard) 
    518       !!        !  93-03  (M. Guyon)  symetrical conditions 
    519       !!        !  98-05  (B. Blanke) 
    520       !!   8.5  !  02-08  (G. Madec)  F90: Free form 
    521       !!---------------------------------------------------------------------- 
    522       !! * Arguments 
    523       REAL(wp), INTENT( IN   ), DIMENSION(:,:) ::   & 
    524          px1, py1          ! two horizontal components to be rotated 
    525       REAL(wp), INTENT( OUT  ), DIMENSION(:,:) ::   & 
    526          px2, py2          ! the two horizontal components in the model repere 
    527       INTEGER, INTENT( IN ) ::   & 
    528          kchoix   ! type of transformation 
    529                   ! = 1 change from geographic to model grid. 
    530                   ! =-1 change from model to geographic grid 
    531       CHARACTER(len=1), INTENT( IN ), OPTIONAL ::   cd_type      ! define the nature of pt2d array grid-points 
     367      !!              and a stretched coordinates grid. 
     368      !!---------------------------------------------------------------------- 
     369      REAL(wp), DIMENSION(:,:)  , INTENT(in   ) ::   px1, py1   ! the 2 horizontal components to be rotated 
     370      REAL(wp), DIMENSION(:,:)  , INTENT(  out) ::   px2, py2   ! the 2 horizontal components in the model repere 
     371      INTEGER                   , INTENT(in   ) ::   kchoix     ! = 1 change from geographic to model grid. 
     372      !                                                         ! =-1 change from model to geographic grid 
     373      CHARACTER(len=1), OPTIONAL, INTENT(in   ) ::   cd_type    ! define the nature of pt2d array grid-points 
    532374      ! 
    533375      CHARACTER(len=1) ::   cl_type      ! define the nature of pt2d array grid-points (T point by default) 
    534376      !!---------------------------------------------------------------------- 
    535  
     377      ! 
    536378      cl_type = 'T' 
    537379      IF( PRESENT(cd_type) )   cl_type = cd_type 
    … …  
    546388      CASE DEFAULT   ;   CALL ctl_stop( 'repere: Syntax Error in the definition of kchoix (1 OR -1' ) 
    547389      END SELECT 
     390      ! 
     391   END SUBROUTINE repere 
     392 
     393 
     394   SUBROUTINE rot_rep( pxin, pyin, cd_type, cdtodo, prot ) 
     395      !!---------------------------------------------------------------------- 
     396      !!                  ***  ROUTINE rot_rep  *** 
     397      !! 
     398      !! ** Purpose :   Rotate the Repere: Change vector componantes between 
     399      !!                geographic grid <--> stretched coordinates grid. 
     400      !!---------------------------------------------------------------------- 
     401      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   pxin, pyin   ! vector componantes 
     402      CHARACTER(len=1),             INTENT(in   ) ::   cd_type      ! define the nature of pt2d array grid-points 
     403      CHARACTER(len=5),             INTENT(in   ) ::   cdtodo       ! specify the work to do: 
     404      !!                                                            ! 'en->i' east-north componantes to model i-componante 
     405      !!                                                            ! 'en->j' east-north componantes to model j-componante 
     406      !!                                                            ! 'ij->e' model i-j componantes to east componante 
     407      !!                                                            ! 'ij->n' model i-j componantes to east componante 
     408      REAL(wp), DIMENSION(jpi,jpj), INTENT(  out) ::   prot         ! 
     409      ! 
     410      INTEGER ::   ipt   ! 
     411      !!---------------------------------------------------------------------- 
     412 
     413      CALL angle_msh_geo   ! initialization of the transformation (just a return if not the 1st call) 
    548414       
    549    END SUBROUTINE repere 
    550  
    551  
    552    SUBROUTINE obs_rot ( psinu, pcosu, psinv, pcosv ) 
    553       !!---------------------------------------------------------------------- 
    554       !!                  ***  ROUTINE obs_rot  *** 
    555       !! 
    556       !! ** Purpose :   Copy gsinu, gcosu, gsinv and gsinv 
    557       !!                to input data for rotations of 
    558       !!                current at observation points 
    559       !! 
    560       !! History : 
    561       !!   9.2  !  09-02  (K. Mogensen) 
    562       !!---------------------------------------------------------------------- 
    563       REAL(wp), DIMENSION(jpi,jpj), INTENT( OUT )::   & 
    564          & psinu, pcosu, psinv, pcosv! copy of data 
    565  
    566       !!---------------------------------------------------------------------- 
    567  
    568       ! Initialization of gsin* and gcos* at first call 
    569       ! ----------------------------------------------- 
    570  
    571       IF( lmust_init ) THEN 
    572          IF(lwp) WRITE(numout,*) 
    573          IF(lwp) WRITE(numout,*) ' obs_rot : geographic <--> stretched' 
    574          IF(lwp) WRITE(numout,*) ' ~~~~~~~   coordinate transformation' 
    575  
    576          CALL angle       ! initialization of the transformation 
    577          lmust_init = .FALSE. 
    578  
    579       ENDIF 
    580  
    581       psinu(:,:) = gsinu(:,:) 
    582       pcosu(:,:) = gcosu(:,:) 
    583       psinv(:,:) = gsinv(:,:) 
    584       pcosv(:,:) = gcosv(:,:) 
    585  
    586    END SUBROUTINE obs_rot 
    587  
     415      SELECT CASE (cd_type) 
     416      CASE ('T')   ;   ipt = 1 
     417      CASE ('U')   ;   ipt = 2 
     418      CASE ('V')   ;   ipt = 3 
     419      CASE ('F')   ;   ipt = 4 
     420      CASE DEFAULT   ;   CALL ctl_stop( 'Only T, U, V and F grid points are coded' ) 
     421      END SELECT 
     422       
     423      SELECT CASE (cdtodo) 
     424      CASE ('en->i')   ;   prot(:,:) = pxin(:,:) * gcos(:,:,ipt) + pyin(:,:) * gsin(:,:,ipt)    ! east-north to model i-component 
     425      CASE ('en->j')   ;   prot(:,:) = pyin(:,:) * gcos(:,:,ipt) - pxin(:,:) * gsin(:,:,ipt)    ! east-north to model j-component 
     426      CASE ('ij->e')   ;   prot(:,:) = pxin(:,:) * gcos(:,:,ipt) - pyin(:,:) * gsin(:,:,ipt)    ! model i-j  to east    component 
     427      CASE ('ij->n')   ;   prot(:,:) = pyin(:,:) * gcos(:,:,ipt) + pxin(:,:) * gsin(:,:,ipt)    ! model i-j  to north   component 
     428      CASE DEFAULT   ;   CALL ctl_stop( 'rot_rep: Syntax Error in the definition of cdtodo' ) 
     429      END SELECT 
     430       
     431   END SUBROUTINE rot_rep 
    588432 
    589433  !!====================================================================== 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/SBC/oasis4_date.F90

    r2528 r2620  
    11MODULE oasis4_date 
    2    !!--------------------------------------------------------------------- 
    3    !!                     ***  oasis_date.h90  ***   
     2   !!====================================================================== 
     3   !!                     ***  MODULE oasis_date  ***   
    44   !!   Date and related information required to couple NEMO via OASIS4 
    55   !!   Made separate from cpl_oasis4 module to allow wider use. 
    6    !!===================================================================== 
    7    !! History :    
    8    !!   9.0  !  05-12  (R. Hill, Met. Office) Original code 
     6   !!====================================================================== 
     7   !! History :  2.0  ! 2005-12  (R. Hill, Met. Office) Original code 
    98   !!---------------------------------------------------------------------- 
    109#if defined key_oasis4 
     10   !!---------------------------------------------------------------------- 
     11   !!   'key_oasis4'                                   coupled with OASIS-4 
     12   !!---------------------------------------------------------------------- 
     13   !##################### WARNING coupled mode ############################### 
     14   !##################### WARNING coupled mode ############################### 
     15   !   Following line must be enabled if coupling with OASIS 
     16   !   USE PRISM 
     17   !##################### WARNING coupled mode ############################### 
     18   !##################### WARNING coupled mode ############################### 
     19 
     20   PRIVATE 
     21   IMPLICIT NONE 
     22 
     23   INTEGER, PUBLIC :: date_err, date_info   !:  
     24 
     25   TYPE(PRISM_Time_struct), PUBLIC ::   dates            !: date info for send operation 
     26   TYPE(PRISM_Time_struct), PUBLIC ::   dates_bound(2)   !: date info for send operation 
     27   TYPE(PRISM_Time_struct), PUBLIC ::   dater            !: date info for receive operation 
     28   TYPE(PRISM_Time_struct), PUBLIC ::   dater_bound(2)   !: date info for receive operation 
     29   TYPE(PRISM_Time_struct), PUBLIC ::   tmpdate          !: 
     30    
     31#else 
     32   !!---------------------------------------------------------------------- 
     33   !!   Default option            Dummy module                   NO OASIS-4 
     34   !!---------------------------------------------------------------------- 
     35#endif 
    1136   !!---------------------------------------------------------------------- 
    1237   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    1338   !! $Id$ 
    1439   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    15    !!---------------------------------------------------------------------- 
    16 !##################### WARNING coupled mode ############################### 
    17 !##################### WARNING coupled mode ############################### 
    18 !   Following line must be enabled if coupling with OASIS 
    19 !   USE PRISM 
    20 !##################### WARNING coupled mode ############################### 
    21 !##################### WARNING coupled mode ############################### 
    22  
    23    IMPLICIT NONE 
    24  
    25    INTEGER :: date_err, date_info 
    26    !!--------------------------------------------------------------------- 
    27    TYPE(PRISM_Time_struct), PUBLIC    :: dates          ! date info for send operation 
    28    TYPE(PRISM_Time_struct), PUBLIC    :: dates_bound(2) ! date info for send operation 
    29    TYPE(PRISM_Time_struct), PUBLIC    :: dater          ! date info for receive operation 
    30    TYPE(PRISM_Time_struct), PUBLIC    :: dater_bound(2) ! date info for receive operation 
    31    TYPE(PRISM_Time_struct), PUBLIC    :: tmpdate 
    32 #endif 
     40   !!====================================================================== 
    3341END MODULE oasis4_date 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/SBC/sbc_ice.F90

    r2613 r2620  
    1919   USE par_ice_2        ! LIM-2 parameters 
    2020# endif 
     21   USE lib_mpp          ! MPP library 
     22   USE in_out_manager   ! I/O manager 
    2123 
    2224   IMPLICIT NONE 
    2325   PRIVATE 
    2426 
    25    PUBLIC sbc_ice_alloc ! called in nemogcm.F90 
     27   PUBLIC sbc_ice_alloc ! called in iceini(_2).F90 
    2628 
    2729# if defined  key_lim2 
    … …  
    4850   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   alb_ice   !: albedo of ice 
    4951 
    50    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   utau_ice    !: atmos-ice u-stress. VP: I-pt ; EVP: U,V-pts   [N/m2] 
    51    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   vtau_ice    !: atmos-ice v-stress. VP: I-pt ; EVP: U,V-pts   [N/m2] 
    52    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   fr1_i0      !: 1st Qsr fraction penetrating inside ice cover    [-] 
    53    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   fr2_i0      !: 2nd Qsr fraction penetrating inside ice cover    [-] 
    54    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   emp_ice     !: sublimation-snow budget over ice             [kg/m2] 
     52   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   utau_ice  !: atmos-ice u-stress. VP: I-pt ; EVP: U,V-pts   [N/m2] 
     53   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   vtau_ice  !: atmos-ice v-stress. VP: I-pt ; EVP: U,V-pts   [N/m2] 
     54   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   fr1_i0    !: 1st Qsr fraction penetrating inside ice cover    [-] 
     55   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   fr2_i0    !: 2nd Qsr fraction penetrating inside ice cover    [-] 
     56   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   emp_ice   !: sublimation-snow budget over ice             [kg/m2] 
    5557 
    5658# if defined key_lim3 
    … …  
    6567CONTAINS 
    6668 
    67    FUNCTION sbc_ice_alloc() 
     69   INTEGER FUNCTION sbc_ice_alloc() 
    6870      !!---------------------------------------------------------------------- 
    69      !!                     ***  FUNCTION sbc_ice_alloc  *** 
    70      !! 
    71      !! ** Purpose :   Allocate all the dynamic arrays in the modules 
     71      !!                     ***  FUNCTION sbc_ice_alloc  *** 
    7272      !!---------------------------------------------------------------------- 
    73       INTEGER :: sbc_ice_alloc   ! return value 
    74       !!---------------------------------------------------------------------- 
    75       ! 
    7673      ALLOCATE( qns_ice (jpi,jpj,jpl) , qsr_ice (jpi,jpj,jpl) ,     & 
    7774         &      qla_ice (jpi,jpj,jpl) , dqla_ice(jpi,jpj,jpl) ,     & 
    … …  
    8077         &      utau_ice(jpi,jpj)     , vtau_ice(jpi,jpj)     ,     & 
    8178         &      fr1_i0  (jpi,jpj)     , fr2_i0  (jpi,jpj)     ,     & 
    82          &      emp_ice(jpi,jpj)                              , STAT=sbc_ice_alloc) 
    83       ! 
    84   END FUNCTION sbc_ice_alloc 
     79         &      emp_ice(jpi,jpj)                              , STAT=sbc_ice_alloc ) 
     80         ! 
     81      IF( lk_mpp            )   CALL mpp_sum ( sbc_ice_alloc ) 
     82      IF( sbc_ice_alloc > 0 )   CALL ctl_warn('sbc_ice_alloc: allocation of arrays failed') 
     83   END FUNCTION sbc_ice_alloc 
    8584 
    8685#else 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/SBC/sbc_oce.F90

    r2590 r2620  
    1010   !!            3.3  ! 2010-10  (J. Chanut, C. Bricaud)  add the surface pressure forcing 
    1111   !!---------------------------------------------------------------------- 
    12    USE par_oce          ! ocean parameters 
     12 
     13   !!---------------------------------------------------------------------- 
     14   !!   sbc_oce_alloc : allocation of sbc arrays 
     15   !!   sbc_tau2wnd   : wind speed estimated from wind stress 
     16   !!---------------------------------------------------------------------- 
     17   USE par_oce        ! ocean parameters 
     18   USE in_out_manager ! I/O manager 
     19   USE lib_mpp        ! MPP library 
    1320 
    1421   IMPLICIT NONE 
    1522   PRIVATE 
    1623 
    17    PUBLIC sbc_oce_alloc ! routine called in nemogcm.F90 
    18  
     24   PUBLIC   sbc_oce_alloc   ! routine called in sbcmod.F90 
     25   PUBLIC   sbc_tau2wnd     ! routine called in several sbc modules 
     26    
    1927   !!---------------------------------------------------------------------- 
    2028   !!           Namelist for the Ocean Surface Boundary Condition 
    2129   !!---------------------------------------------------------------------- 
    22    !                                             !! * namsbc namelist * 
     30   !                                            !!* namsbc namelist * 
    2331   LOGICAL , PUBLIC ::   ln_ana      = .FALSE.   !: analytical boundary condition flag 
    2432   LOGICAL , PUBLIC ::   ln_flx      = .FALSE.   !: flux      formulation 
    … …  
    7583   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ssh_m     !: mean (nn_fsbc time-step) sea surface height                [m] 
    7684 
     85   !! * Substitutions 
     86#  include "vectopt_loop_substitute.h90" 
    7787   !!---------------------------------------------------------------------- 
    78    !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
     88   !! NEMO/OPA 4.0 , NEMO Consortium (2011) 
    7989   !! $Id$ 
    8090   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    81    !!====================================================================== 
     91   !!---------------------------------------------------------------------- 
    8292CONTAINS 
    8393 
    84    FUNCTION sbc_oce_alloc() 
     94   INTEGER FUNCTION sbc_oce_alloc() 
    8595      !!--------------------------------------------------------------------- 
    86       !!                  ***  ROUTINE sbc_oce_alloc  *** 
     96      !!                  ***  FUNCTION sbc_oce_alloc  *** 
    8797      !!--------------------------------------------------------------------- 
    88       USE in_out_manager, ONLY: ctl_warn 
    89       IMPLICIT none 
    90       INTEGER :: sbc_oce_alloc 
    91       ! Local variables 
    9298      INTEGER :: ierr(4) 
    9399      !!--------------------------------------------------------------------- 
    94  
    95100      ierr(:) = 0 
    96  
    97       ALLOCATE(utau(jpi,jpj),    utau_b(jpi,jpj),                      & 
    98                vtau(jpi,jpj),    vtau_b(jpi,jpj),                      & 
    99                taum(jpi,jpj),    wndm(jpi,jpj)  , Stat=ierr(1))  
    100  
    101       ALLOCATE(qsr(jpi,jpj),     qns(jpi,jpj),    qns_b(jpi,jpj),      & 
    102                qsr_tot(jpi,jpj), qns_tot(jpi,jpj),                     & 
    103                emp(jpi,jpj),     emp_b(jpi,jpj),                       & 
    104                emps(jpi,jpj),    emps_b(jpi,jpj), emp_tot(jpi,jpj),    & 
    105                Stat=ierr(2)) 
    106  
    107       ALLOCATE(rnf(jpi,jpj),          rnf_b(jpi,jpj),                       & 
    108                sbc_tsc(jpi,jpj,jpts), sbc_tsc_b(jpi,jpj,jpts),         &   
    109                qsr_hc(jpi,jpj,jpk) ,  qsr_hc_b(jpi,jpj,jpk),  Stat=ierr(3)) 
    110  
    111       ALLOCATE(tprecip(jpi,jpj),      sprecip(jpi,jpj), fr_i(jpi,jpj), & 
     101      ! 
     102      ALLOCATE( utau(jpi,jpj) , utau_b(jpi,jpj) , taum(jpi,jpj) ,     & 
     103         &      vtau(jpi,jpj) , vtau_b(jpi,jpj) , wndm(jpi,jpj) , STAT=ierr(1) )  
     104         ! 
     105      ALLOCATE( qns_tot(jpi,jpj) , qns   (jpi,jpj) , qns_b(jpi,jpj),      & 
     106         &      qsr_tot(jpi,jpj) , qsr   (jpi,jpj) ,                     & 
     107         &      emp    (jpi,jpj) , emp_b (jpi,jpj) ,                       & 
     108         &      emps   (jpi,jpj) , emps_b(jpi,jpj) , emp_tot(jpi,jpj) , STAT=ierr(2)) 
     109         ! 
     110      ALLOCATE( rnf  (jpi,jpj) , sbc_tsc  (jpi,jpj,jpts) , qsr_hc  (jpi,jpj,jpk) ,     & 
     111         &      rnf_b(jpi,jpj) , sbc_tsc_b(jpi,jpj,jpts) , qsr_hc_b(jpi,jpj,jpk) , STAT=ierr(3) ) 
     112         ! 
     113      ALLOCATE( tprecip(jpi,jpj) , sprecip(jpi,jpj) , fr_i(jpi,jpj) ,     & 
    112114#if defined key_cpl_carbon_cycle 
    113                atm_co2(jpi,jpj),                                       & 
     115         &      atm_co2(jpi,jpj) ,                                        & 
    114116#endif 
    115                ssu_m(jpi,jpj), ssv_m(jpi,jpj), sst_m(jpi,jpj),         & 
    116                sss_m(jpi,jpj), ssh_m(jpi,jpj), Stat=ierr(4)) 
    117  
    118       sbc_oce_alloc = MAXVAL(ierr) 
    119  
    120       IF(sbc_oce_alloc > 0)THEN 
    121          CALL ctl_warn('sbc_oce_alloc: allocation of arrays failed.') 
    122       END IF 
    123  
     117         &      ssu_m  (jpi,jpj) , sst_m(jpi,jpj) ,                       & 
     118         &      ssv_m  (jpi,jpj) , sss_m  (jpi,jpj), ssh_m(jpi,jpj) , STAT=ierr(4) ) 
     119         ! 
     120      sbc_oce_alloc = MAXVAL( ierr ) 
     121      IF( lk_mpp            )   CALL mpp_sum ( sbc_oce_alloc ) 
     122      IF( sbc_oce_alloc > 0 )   CALL ctl_warn('sbc_oce_alloc: allocation of arrays failed') 
     123      ! 
    124124   END FUNCTION sbc_oce_alloc 
    125125 
    … …  
    139139      REAL(wp) ::   ztx, zty, ztau, zcoef ! temporary variables 
    140140      INTEGER  ::   ji, jj                ! dummy indices 
    141       !! * Substitutions 
    142 #  include "vectopt_loop_substitute.h90" 
    143141      !!--------------------------------------------------------------------- 
    144142      zcoef = 0.5 / ( zrhoa * zcdrag )  
    … …  
    154152      END DO 
    155153      CALL lbc_lnk( wndm(:,:) , 'T', 1. ) 
    156  
     154      ! 
    157155   END SUBROUTINE sbc_tau2wnd 
    158156 
     157   !!====================================================================== 
    159158END MODULE sbc_oce 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/SBC/sbcana.F90

    r2548 r2620  
    4242   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    4343   !! $Id$ 
    44    !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    45    !!---------------------------------------------------------------------- 
    46  
     44   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
     45   !!---------------------------------------------------------------------- 
    4746CONTAINS 
    4847 
    … …  
    9291      ENDIF 
    9392 
    94       qns   (:,:) = rn_qns0 
    95       qsr   (:,:) = rn_qsr0 
    96       emp   (:,:) = rn_emp0 
    97       emps  (:,:) = rn_emp0 
     93      qns (:,:) = rn_qns0 
     94      qsr (:,:) = rn_qsr0 
     95      emp (:,:) = rn_emp0 
     96      emps(:,:) = rn_emp0 
    9897    
    9998      ! Increase the surface stress to its nominal value during the first nn_tau000 time-steps 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/SBC/sbcapr.F90

    r2528 r2620  
    1919   USE in_out_manager  ! I/O manager 
    2020   USE lib_fortran     ! distribued memory computing library 
    21    USE iom 
    22    USE restart 
     21   USE iom             ! IOM library 
     22   USE restart         ! ocean restart 
    2323 
    2424   IMPLICIT NONE 
    … …  
    3232   LOGICAL, PUBLIC ::   ln_ref_apr = .FALSE.  !: ref. pressure: global mean Patm (F) or a constant (F) 
    3333 
    34    REAL(wp), ALLOCATABLE, PUBLIC, DIMENSION(:,:) ::   ssh_ib    ! Inverse barometer now    sea surface height     [m] 
    35    REAL(wp), ALLOCATABLE, PUBLIC, DIMENSION(:,:) ::   ssh_ibb   ! Inverse barometer before sea surface height     [m] 
    36    REAL(wp), ALLOCATABLE, PUBLIC, DIMENSION(:,:) ::   apr       ! atmospheric pressure at kt                   [N/m2] 
     34   REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) ::   ssh_ib    ! Inverse barometer now    sea surface height   [m] 
     35   REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) ::   ssh_ibb   ! Inverse barometer before sea surface height   [m] 
     36   REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) ::   apr       ! atmospheric pressure at kt                 [N/m2] 
    3737    
    3838   REAL(wp) ::   rpref = 101000._wp   ! reference atmospheric pressure          [N/m2] 
    3939   REAL(wp) ::   tarea                ! whole domain mean masked ocean surface 
    4040   REAL(wp) ::   r1_grau              ! = 1.e0 / (grav * rau0) 
    41  
    4241    
    43    TYPE(FLD), ALLOCATABLE, DIMENSION(:)  ::   sf_apr   ! structure of input fields (file informations, fields read) 
     42   TYPE(FLD), ALLOCATABLE, SAVE, DIMENSION(:) ::   sf_apr   ! structure of input fields (file informations, fields read) 
    4443 
    4544   !! * Substitutions 
    4645#  include "domzgr_substitute.h90" 
    4746   !!---------------------------------------------------------------------- 
    48    !! NEMO/OPA 3.3 , NEMO Consortium (2010)  
    49    !! $Id $ 
    50    !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 
     47   !! NEMO/OPA 4.0 , NEMO Consortium (2011)  
     48   !! $Id: $ 
     49   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    5150   !!---------------------------------------------------------------------- 
    5251CONTAINS 
    … …  
    9190         ! 
    9291         ALLOCATE( sf_apr(1), STAT=ierror )           !* allocate and fill sf_sst (forcing structure) with sn_sst 
    93          IF( ierror > 0 ) THEN 
    94             CALL ctl_stop( 'sbc_apr: unable to allocate sf_apr structure' )   ;   RETURN 
    95          ENDIF 
     92         IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_apr: unable to allocate sf_apr structure' ) 
     93         ! 
    9694         CALL fld_fill( sf_apr, (/ sn_apr /), cn_dir, 'sbc_apr', 'Atmospheric pressure ', 'namsbc_apr' ) 
    9795                                ALLOCATE( sf_apr(1)%fnow(jpi,jpj,1)   ) 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_clio.F90

    r2590 r2620  
    4343   PUBLIC sbc_blk_clio        ! routine called by sbcmod.F90  
    4444   PUBLIC blk_ice_clio        ! routine called by sbcice_lim.F90  
    45    PUBLIC sbc_blk_clio_alloc  ! routine called by nemogcm.F90 
    4645 
    4746   INTEGER , PARAMETER ::   jpfld   = 7           ! maximum number of files to read  
    … …  
    7776   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   stauc        ! cloud optical depth  
    7877    
    79    REAL(wp)  ::   zeps    = 1.e-20                ! constant values 
    80    REAL(wp)  ::   zeps0   = 1.e-13   
     78   REAL(wp) ::   eps20  = 1.e-20   ! constant values 
    8179    
    8280   !! * Substitutions 
    8381#  include "vectopt_loop_substitute.h90" 
    8482   !!---------------------------------------------------------------------- 
    85    !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
     83   !! NEMO/OPA 4.0 , NEMO Consortium (2011) 
    8684   !! $Id$  
    8785   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    8886   !!---------------------------------------------------------------------- 
    8987CONTAINS 
    90  
    91    FUNCTION sbc_blk_clio_alloc() 
    92       !!--------------------------------------------------------------------- 
    93       !!                 ***  ROUTINE sbc_blk_clio_alloc  *** 
    94       !!--------------------------------------------------------------------- 
    95       IMPLICIT none 
    96       INTEGER :: sbc_blk_clio_alloc 
    97       !!--------------------------------------------------------------------- 
    98  
    99       ALLOCATE(sbudyko(jpi,jpj), & 
    100                stauc(jpi,jpj),   & 
    101                Stat=sbc_blk_clio_alloc) 
    102  
    103    END FUNCTION sbc_blk_clio_alloc 
    10488 
    10589   SUBROUTINE sbc_blk_clio( kt ) 
    … …  
    134118      !! 
    135119      INTEGER  ::   ifpr, jfpr         ! dummy indices 
    136       INTEGER  ::   ierror             ! return error code 
     120      INTEGER  ::   ierr0, ierr1, ierr2, ierr3   ! return error code 
    137121      !! 
    138122      CHARACTER(len=100) ::  cn_dir                            !   Root directory for location of CLIO files 
    … …  
    171155          
    172156         ! set sf structure 
    173          ALLOCATE( sf(jpfld), STAT=ierror ) 
    174          IF( ierror > 0 ) THEN 
    175             CALL ctl_stop( 'sbc_blk_clio: unable to allocate sf structure' )   ;   RETURN 
    176          ENDIF 
     157         ALLOCATE( sf(jpfld), STAT=ierr0 ) 
     158         IF( ierr0 > 0 )   CALL ctl_stop( 'STOP', 'sbc_blk_clio: unable to allocate sf structure' ) 
    177159         DO ifpr= 1, jpfld 
    178             ALLOCATE( sf(ifpr)%fnow(jpi,jpj,1) ) 
    179             IF( slf_i(ifpr)%ln_tint ) ALLOCATE( sf(ifpr)%fdta(jpi,jpj,1,2) ) 
    180          END DO 
     160            ALLOCATE( sf(ifpr)%fnow(jpi,jpj,1) , STAT=ierr1) 
     161            IF( slf_i(ifpr)%ln_tint ) ALLOCATE( sf(ifpr)%fdta(jpi,jpj,1,2) , STAT=ierr2 ) 
     162         END DO 
     163         IF( ierr1+ierr2 > 0 )   CALL ctl_stop( 'STOP', 'sbc_blk_clio: unable to allocate sf array structure' ) 
    181164         ! fill sf with slf_i and control print 
    182165         CALL fld_fill( sf, slf_i, cn_dir, 'sbc_blk_clio', 'flux formulation for ocean surface boundary condition', 'namsbc_clio' ) 
     166          
     167         ! allocate sbcblk clio arrays 
     168         ALLOCATE( sbudyko(jpi,jpj) , stauc(jpi,jpj), STAT=ierr3 ) 
     169         IF( ierr3 > 0 )   CALL ctl_stop( 'STOP', 'sbc_blk_clio: unable to allocate arrays' ) 
    183170         ! 
    184171      ENDIF 
    … …  
    330317            zdeltaq = zqatm - zqsato 
    331318            ztvmoy  = ztatm * ( 1. + 2.2e-3 * ztatm * zqatm ) 
    332             zdenum  = MAX( sf(jp_wndm)%fnow(ji,jj,1) * sf(jp_wndm)%fnow(ji,jj,1) * ztvmoy, zeps ) 
     319            zdenum  = MAX( sf(jp_wndm)%fnow(ji,jj,1) * sf(jp_wndm)%fnow(ji,jj,1) * ztvmoy, eps20 ) 
    333320            zdtetar = zdteta / zdenum 
    334321            ztvmoyr = ztvmoy * ztvmoy * zdeltaq / zdenum 
    … …  
    352339            zpsil   = zpsih 
    353340             
    354             zvatmg         = MAX( 0.032 * 1.5e-3 * sf(jp_wndm)%fnow(ji,jj,1) * sf(jp_wndm)%fnow(ji,jj,1) / grav, zeps ) 
     341            zvatmg         = MAX( 0.032 * 1.5e-3 * sf(jp_wndm)%fnow(ji,jj,1) * sf(jp_wndm)%fnow(ji,jj,1) / grav, eps20 ) 
    355342            zcmn           = vkarmn / LOG ( 10. / zvatmg ) 
    356343            zchn           = 0.0327 * zcmn 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_core.F90

    r2590 r2620  
    7878   !!---------------------------------------------------------------------- 
    7979CONTAINS 
    80  
    8180 
    8281   SUBROUTINE sbc_blk_core( kt ) 
    … …  
    167166         ! 
    168167         ALLOCATE( sf(jfld), STAT=ierror )         ! set sf structure 
    169          IF( ierror > 0 ) THEN 
    170             CALL ctl_stop( 'sbc_blk_core: unable to allocate sf structure' )   ;   RETURN 
    171          ENDIF 
     168         IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_blk_core: unable to allocate sf structure' ) 
    172169         DO ifpr= 1, jfld 
    173170            ALLOCATE( sf(ifpr)%fnow(jpi,jpj,1) ) 
    174             IF( slf_i(ifpr)%ln_tint ) ALLOCATE( sf(ifpr)%fdta(jpi,jpj,1,2) ) 
     171            IF( slf_i(ifpr)%ln_tint )   ALLOCATE( sf(ifpr)%fdta(jpi,jpj,1,2) ) 
    175172         END DO 
    176173         !                                         ! fill sf with slf_i and control print 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/SBC/sbccpl.F90

    r2590 r2620  
    5858   PUBLIC   sbc_cpl_ice_tau    ! routine called by sbc_ice_lim(_2).F90 
    5959   PUBLIC   sbc_cpl_ice_flx    ! routine called by sbc_ice_lim(_2).F90 
    60    PUBLIC   sbc_cpl_init_alloc ! routine called by nemogcm.F90 
    6160 
    6261   INTEGER, PARAMETER ::   jpr_otx1   =  1            ! 3 atmosphere-ocean stress components on grid 1 
    … …  
    155154   INTEGER , ALLOCATABLE, SAVE, DIMENSION(    :) ::   nrcvinfo           ! OASIS info argument 
    156155 
    157 #if ! defined key_lim2 && ! defined key_lim3 
     156#if ! defined key_lim2   &&  ! defined key_lim3 
    158157   ! quick patch to be able to run the coupled model without sea-ice... 
    159158   INTEGER, PARAMETER               ::   jpl = 1  
    … …  
    173172CONTAINS 
    174173   
    175    FUNCTION sbc_cpl_init_alloc() 
    176       !!---------------------------------------------------------------------- 
    177       !!             ***  ROUTINE sbc_cpl_init_alloc  *** 
    178       !!---------------------------------------------------------------------- 
    179       IMPLICIT none 
    180       INTEGER :: sbc_cpl_init_alloc 
     174   INTEGER FUNCTION sbc_cpl_alloc() 
     175      !!---------------------------------------------------------------------- 
     176      !!             ***  FUNCTION sbc_cpl_alloc  *** 
     177      !!---------------------------------------------------------------------- 
    181178      INTEGER :: ierr(2) 
    182179      !!---------------------------------------------------------------------- 
    183  
    184180      ierr(:) = 0 
    185  
    186       ALLOCATE(albedo_oce_mix(jpi,jpj), & 
    187                frcv(jpi,jpj,jprcv),     & 
    188                nrcvinfo(jprcv),  Stat=Stat=ierr(1)) 
    189  
     181      ! 
     182      ALLOCATE( albedo_oce_mix(jpi,jpj), frcv(jpi,jpj,jprcv), nrcvinfo(jprcv),  STAT=ierr(1) ) 
     183      ! 
    190184#if ! defined key_lim2 && ! defined key_lim3 
    191185      ! quick patch to be able to run the coupled model without sea-ice... 
    192       ALLOCATE(hicif(jpi,jpj), hsnif(jpi,jpj), u_ice(jpi,jpj),  & 
    193                v_ice(jpi,jpj), fr1_i0(jpi,jpj),fr2_i0(jpi,jpj), & 
    194                tn_ice(jpi,jpj,jpl), alb_ice(jpi,jpj,jpl),       & 
    195                Stat=ierr(2) ) 
     186      ALLOCATE( hicif(jpi,jpj) , u_ice(jpi,jpj) , fr1_i0(jpi,jpj) , tn_ice (jpi,jpj,jpl) ,     & 
     187                hsnif(jpi,jpj) , v_ice(jpi,jpj) , fr2_i0(jpi,jpj) , alb_ice(jpi,jpj,jpl) , STAT=ierr(2) ) 
    196188#endif 
    197  
    198       sbc_cpl_init_alloc = MAXVAL(ierr) 
    199  
    200       IF(sbc_cpl_init_alloc > 0)THEN 
    201          CALL ctl_warn('sbc_cpl_init_alloc: allocation of arrays failed.') 
    202       END IF 
    203  
    204     END FUNCTION sbc_cpl_init_alloc 
     189      sbc_cpl_init_alloc = MAXVAL( ierr ) 
     190      IF( lk_mpp            )   CALL mpp_sum ( sbc_cpl_alloc ) 
     191      IF( sbc_cpl_alloc > 0 )   CALL ctl_warn('sbc_cpl_alloc: allocation of arrays failed') 
     192      ! 
     193   END FUNCTION sbc_cpl_alloc 
     194 
    205195 
    206196   SUBROUTINE sbc_cpl_init( k_ice )      
    … …  
    233223      !!--------------------------------------------------------------------- 
    234224 
    235       IF(.not. wrk_use(2,1,2))THEN 
    236          CALL ctl_stop('sbc_cpl_init: requested workspace arrays unavailable.') 
    237          RETURN 
     225      IF(.NOT. wrk_use(2,1,2) ) THEN 
     226         CALL ctl_stop('sbc_cpl_init: requested workspace arrays unavailable.')   ;   RETURN 
    238227      END IF 
    239228 
    … …  
    273262 
    274263#if defined key_cpl_carbon_cycle  
    275       REWIND( numnam )                    ! ... read namlist namsbc_cpl_co2 
     264      REWIND( numnam )                    ! read namlist namsbc_cpl_co2 
    276265      READ  ( numnam, namsbc_cpl_co2 ) 
    277266      IF(lwp) THEN                        ! control print 
    … …  
    291280      cn_rcv_tau(1) = TRIM( cn_rcv_tau_nature )   ;   cn_rcv_tau(2) = TRIM( cn_rcv_tau_refere ) 
    292281      cn_rcv_tau(3) = TRIM( cn_rcv_tau_orient )   ;   cn_rcv_tau(4) = TRIM( cn_rcv_tau_grid   ) 
     282 
     283      !                                   ! allocate zdfric arrays 
     284      IF( sbc_cpl_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'sbc_cpl_alloc : unable to allocate arrays' ) 
    293285      
    294286      ! ================================ ! 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/SBC/sbcdcy.F90

    r2590 r2620  
    2121   IMPLICIT NONE 
    2222   PRIVATE 
    23    INTEGER, PUBLIC              ::   nday_qsr                    ! day when parameters were computed 
    24    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   raa , rbb  , rcc  , rab     ! parameters used to compute the diurnal cycle 
    25    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   rtmd, rdawn, rdusk, rscal   !     -       -         -           -      - 
     23    
     24   INTEGER, PUBLIC ::   nday_qsr   !: day when parameters were computed 
     25    
     26   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   raa , rbb  , rcc  , rab     ! diurnal cycle parameters 
     27   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   rtmd, rdawn, rdusk, rscal   !    -      -       - 
    2628   
    2729   PUBLIC   sbc_dcy        ! routine called by sbc 
    28    PUBLIC   sbc_dcy_alloc  ! routine called by nemogcm.F90 
    2930 
    3031   !!---------------------------------------------------------------------- 
    … …  
    3536CONTAINS 
    3637 
    37       FUNCTION sbc_dcy_alloc() 
     38      INTEGER FUNCTION sbc_dcy_alloc() 
    3839         !!---------------------------------------------------------------------- 
    39          !!                ***  ROUTINE sbc_dcy_alloc  *** 
     40         !!                ***  FUNCTION sbc_dcy_alloc  *** 
    4041         !!---------------------------------------------------------------------- 
    41          IMPLICIT none 
    42          INTEGER :: sbc_dcy_alloc 
    43          !!---------------------------------------------------------------------- 
    44  
    45          ALLOCATE(raa(jpi,jpj),  rbb(jpi,jpj),   rcc(jpi,jpj),   rab(jpi,jpj),   & 
    46                   rtmd(jpi,jpj), rdawn(jpi,jpj), rdusk(jpi,jpj), rscal(jpi,jpj), & 
    47                   Stat=sbc_dcy_alloc) 
    48  
    49          IF(sbc_dcy_alloc /= 0)THEN 
    50             CALL ctl_warn('sbc_dcy_alloc: failed to allocate arrays.') 
    51          END IF 
    52  
     42         ! 
     43         ALLOCATE( raa (jpi,jpj) , rbb  (jpi,jpj) , rcc  (jpi,jpj) , rab  (jpi,jpj) ,     & 
     44            &      rtmd(jpi,jpj) , rdawn(jpi,jpj) , rdusk(jpi,jpj) , rscal(jpi,jpj) , STAT=sbc_dcy_alloc ) 
     45            ! 
     46         IF( lk_mpp             )   CALL mpp_sum ( sbc_dcy_alloc ) 
     47         IF( sbc_dcy_alloc /= 0 )   CALL ctl_warn('sbc_dcy_alloc: failed to allocate arrays') 
     48         ! 
    5349      END FUNCTION sbc_dcy_alloc 
    5450 
    5551 
    56       FUNCTION sbc_dcy( pqsrin ) RESULT( zqsrout ) 
     52   FUNCTION sbc_dcy( pqsrin ) RESULT( zqsrout ) 
    5753      !!---------------------------------------------------------------------- 
    5854      !!                  ***  ROUTINE sbc_dcy  *** 
    … …  
    8581      ! Initialization 
    8682      ! -------------- 
    87       ztwopi    = 2. * rpi 
    88       zinvtwopi = 1. / ztwopi 
    89       zconvrad  = ztwopi / 360. 
     83      ztwopi    = 2._wp * rpi 
     84      zinvtwopi = 1._wp / ztwopi 
     85      zconvrad  = ztwopi / 360._wp 
    9086 
    9187      ! When are we during the day (from 0 to 1) 
    92       zlo = ( REAL(nsec_day, wp) - 0.5   * rdttra(1) ) / rday 
    93       zup = zlo + ( REAL(nn_fsbc, wp) * rdttra(1) ) / rday 
    94  
     88      zlo = ( REAL(nsec_day, wp) - 0.5_wp * rdttra(1) ) / rday 
     89      zup = zlo + ( REAL(nn_fsbc, wp)     * rdttra(1) ) / rday 
    9590      !                                           
    9691      IF( nday_qsr == -1 ) THEN       ! first time step only                
    … …  
    10196            WRITE(numout,*) 
    10297         ENDIF 
     98         ! allocate sbcdcy arrays 
     99         IF( sbc_dcy_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'sbc_dcy_alloc : unable to allocate arrays' ) 
    103100         ! Compute rcc needed to compute the time integral of the diurnal cycle 
    104101         rcc(:,:) = zconvrad * glamt(:,:) - rpi 
    … …  
    156153             END DO   
    157154         END DO   
    158          rdawn(:,:) = MOD((rdawn(:,:) + 1.), 1.) 
    159          rdusk(:,:) = MOD((rdusk(:,:) + 1.), 1.) 
     155         rdawn(:,:) = MOD( (rdawn(:,:) + 1._wp), 1._wp ) 
     156         rdusk(:,:) = MOD( (rdusk(:,:) + 1._wp), 1._wp ) 
    160157 
    161158         !     2.2 Compute the scalling function: 
    … …  
    185182         ztmp = rday / ( rdttra(1) * REAL(nn_fsbc, wp) ) 
    186183         rscal(:,:) = rscal(:,:) * ztmp 
    187  
     184         ! 
    188185      ENDIF  
    189186 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/SBC/sbcflx.F90

    r2528 r2620  
    4242   !! NEMO/OPA 3.3 , NEMO-consortium (2010)  
    4343   !! $Id$ 
    44    !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
     44   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    4545   !!---------------------------------------------------------------------- 
    4646CONTAINS 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/SBC/sbcfwb.F90

    r2590 r2620  
    2828   PRIVATE 
    2929 
    30    PUBLIC   sbc_fwb       ! routine called by step 
    31    PUBLIC   sbc_fwb_alloc ! routine called in nemogcm.F90 
    32  
    33    REAL(wp) ::   a_fwb_b            ! annual domain averaged freshwater budget 
    34    REAL(wp) ::   a_fwb              ! for 2 year before (_b) and before year. 
    35    REAL(wp) ::   fwfold             ! fwfold to be suppressed 
    36    REAL(wp) ::   area               ! global mean ocean surface (interior domain) 
    37  
    38    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   e1e2    ! area of the interior domain (e1t*e2t) 
     30   PUBLIC   sbc_fwb    ! routine called by step 
     31 
     32   REAL(wp) ::   a_fwb_b   ! annual domain averaged freshwater budget 
     33   REAL(wp) ::   a_fwb     ! for 2 year before (_b) and before year. 
     34   REAL(wp) ::   fwfold    ! fwfold to be suppressed 
     35   REAL(wp) ::   area      ! global mean ocean surface (interior domain) 
    3936 
    4037   !! * Substitutions 
    … …  
    4744   !!---------------------------------------------------------------------- 
    4845CONTAINS 
    49  
    50    FUNCTION sbc_fwb_alloc() 
    51       !!--------------------------------------------------------------------- 
    52       !!                ***  ROUTINE sbc_fwb_alloc  *** 
    53       !!--------------------------------------------------------------------- 
    54       IMPLICIT none 
    55       INTEGER :: sbc_fwb_alloc 
    56       !!--------------------------------------------------------------------- 
    57  
    58      ALLOCATE(e1e2(jpi,jpj), Stat=sbc_fwb_alloc) 
    59  
    60      IF(sbc_fwb_alloc /= 0)THEN 
    61         CALL ctl_warn('sbc_fwb_alloc: failed to allocate array.') 
    62      END IF 
    63  
    64    END FUNCTION sbc_fwb_alloc 
    65  
    6646 
    6747   SUBROUTINE sbc_fwb( kt, kn_fwb, kn_fsbc ) 
    … …  
    9373      !!---------------------------------------------------------------------- 
    9474      ! 
    95       IF( .NOT. wrk_use(2, 1,2,3,4,5))THEN 
    96          CALL ctl_stop('sbc_fwb: requested workspace arrays are unavailable.') 
    97          RETURN 
     75      IF( .NOT. wrk_use(2, 1,2,3,4,5) ) THEN 
     76         CALL ctl_stop('sbc_fwb: requested workspace arrays are unavailable')   ;   RETURN 
    9877      END IF 
    9978      ! 
    … …  
    11089         IF( kn_fwb == 3 .AND. nn_sssr /= 2 )   CALL ctl_stop( 'sbc_fwb: nn_fwb = 3 requires nn_sssr = 2, we stop ' ) 
    11190         ! 
    112          e1e2(:,:) = e1t(:,:) * e2t(:,:)  
    113          area = glob_sum( e1e2(:,:) )           ! interior global domain surface 
     91         area = glob_sum( e1e2t(:,:) )           ! interior global domain surface 
    11492      ENDIF 
    11593       
    … …  
    12098         ! 
    12199         IF( MOD( kt-1, kn_fsbc ) == 0 ) THEN 
    122             z_fwf = glob_sum( e1e2(:,:) * ( emp(:,:) - rnf(:,:) ) ) / area   ! sum over the global domain 
     100            z_fwf = glob_sum( e1e2t(:,:) * ( emp(:,:) - rnf(:,:) ) ) / area   ! sum over the global domain 
    123101            emp (:,:) = emp (:,:) - z_fwf  
    124102            emps(:,:) = emps(:,:) - z_fwf  
    … …  
    143121         IF( MOD( kt, ikty ) == 0 ) THEN 
    144122            a_fwb_b = a_fwb 
    145             a_fwb   = glob_sum( e1e2(:,:) * sshn(:,:) )   ! sum over the global domain 
     123            a_fwb   = glob_sum( e1e2t(:,:) * sshn(:,:) )   ! sum over the global domain 
    146124            a_fwb   = a_fwb * 1.e+3 / ( area * 86400. * 365. )     ! convert in Kg/m3/s = mm/s 
    147125!!gm        !                                                      !!bug 365d year  
    … …  
    168146            ztmsk_neg(:,:) = tmask_i(:,:) - ztmsk_pos(:,:) 
    169147            ! 
    170             zsurf_neg = glob_sum( e1e2(:,:)*ztmsk_neg(:,:) )   ! Area filled by <0 and >0 erp  
    171             zsurf_pos = glob_sum( e1e2(:,:)*ztmsk_pos(:,:) ) 
     148            zsurf_neg = glob_sum( e1e2t(:,:)*ztmsk_neg(:,:) )   ! Area filled by <0 and >0 erp  
     149            zsurf_pos = glob_sum( e1e2t(:,:)*ztmsk_pos(:,:) ) 
    172150            !                                                  ! fwf global mean  
    173             z_fwf = glob_sum( e1e2(:,:) * ( emp(:,:) - rnf(:,:) ) ) / area 
     151            z_fwf = glob_sum( e1e2t(:,:) * ( emp(:,:) - rnf(:,:) ) ) / area 
    174152            !             
    175153            IF( z_fwf < 0._wp ) THEN         ! spread out over >0 erp area to increase evaporation 
    … …  
    181159            ENDIF 
    182160            ! 
    183             zsum_fwf   = glob_sum( e1e2(:,:) * z_fwf )         ! fwf global mean over <0 or >0 erp area 
     161            zsum_fwf   = glob_sum( e1e2t(:,:) * z_fwf )         ! fwf global mean over <0 or >0 erp area 
    184162!!gm :  zsum_fwf   = z_fwf * area   ???  it is right?  I think so.... 
    185163            z_fwf_nsrf =  zsum_fwf / ( zsurf_tospread + rsmall ) 
    186164            !                                                  ! weight to respect erp field 2D structure  
    187             zsum_erp = glob_sum( ztmsk_tospread(:,:) * erp(:,:) * e1e2(:,:) ) 
     165            zsum_erp = glob_sum( ztmsk_tospread(:,:) * erp(:,:) * e1e2t(:,:) ) 
    188166            z_wgt(:,:) = ztmsk_tospread(:,:) * erp(:,:) / ( zsum_erp + rsmall ) 
    189167            !                                                  ! final correction term to apply 
    … …  
    200178               IF( z_fwf < 0._wp ) THEN 
    201179                  WRITE(numout,*)'   z_fwf < 0' 
    202                   WRITE(numout,*)'   SUM(erp+)     = ', SUM( ztmsk_tospread(:,:)*erp(:,:)*e1e2(:,:) )*1.e-9,' Sv' 
     180                  WRITE(numout,*)'   SUM(erp+)     = ', SUM( ztmsk_tospread(:,:)*erp(:,:)*e1e2t(:,:) )*1.e-9,' Sv' 
    203181               ELSE 
    204182                  WRITE(numout,*)'   z_fwf >= 0' 
    205                   WRITE(numout,*)'   SUM(erp-)     = ', SUM( ztmsk_tospread(:,:)*erp(:,:)*e1e2(:,:) )*1.e-9,' Sv' 
     183                  WRITE(numout,*)'   SUM(erp-)     = ', SUM( ztmsk_tospread(:,:)*erp(:,:)*e1e2t(:,:) )*1.e-9,' Sv' 
    206184               ENDIF 
    207                WRITE(numout,*)'   SUM(empG)     = ', SUM( z_fwf*e1e2(:,:) )*1.e-9,' Sv' 
     185               WRITE(numout,*)'   SUM(empG)     = ', SUM( z_fwf*e1e2t(:,:) )*1.e-9,' Sv' 
    208186               WRITE(numout,*)'   z_fwf         = ', z_fwf      ,' Kg/m2/s' 
    209187               WRITE(numout,*)'   z_fwf_nsrf    = ', z_fwf_nsrf ,' Kg/m2/s' 
    … …  
    218196      END SELECT 
    219197      ! 
    220       IF( .NOT. wrk_release(2, 1,2,3,4,5))THEN 
    221          CALL ctl_stop('sbc_fwb: failed to release workspace arrays.') 
    222       END IF 
     198      IF( .NOT. wrk_release(2, 1,2,3,4,5) )   CALL ctl_stop('sbc_fwb: failed to release workspace arrays') 
    223199      ! 
    224200   END SUBROUTINE sbc_fwb 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_if.F90

    r2528 r2620  
    3232   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    3333   !! $Id$ 
    34    !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
     34   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    3535   !!---------------------------------------------------------------------- 
    36  
    3736CONTAINS 
    3837 
    … …  
    7877 
    7978         ALLOCATE( sf_ice(1), STAT=ierror ) 
    80          IF( ierror > 0 ) THEN 
    81             CALL ctl_stop( 'sbc_ice_if: unable to allocate sf_ice structure' )   ;   RETURN 
    82          ENDIF 
     79         IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ice_if: unable to allocate sf_ice structure' ) 
    8380         ALLOCATE( sf_ice(1)%fnow(jpi,jpj,1) ) 
    84          IF( sn_ice%ln_tint ) ALLOCATE( sf_ice(1)%fdta(jpi,jpj,1,2) ) 
    85  
     81         IF( sn_ice%ln_tint )   ALLOCATE( sf_ice(1)%fdta(jpi,jpj,1,2) ) 
    8682 
    8783         ! fill sf_ice with sn_ice and control print 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_lim.F90

    r2613 r2620  
    102102      IF( .NOT. wrk_use(3, 1,2) ) THEN 
    103103         CALL ctl_stop( 'sbc_ice_lim: requested workspace arrays are unavailable.' )   ;   RETURN 
    104       ELSEIF( jpl > jpk ) THEN 
    105          CALL ctl_stop( 'sbc_ice_lim: extent of 3rd dimension of workspace arrays needs to exceed jpk.' )   ;   RETURN 
    106104      ENDIF 
    107105 
    … …  
    254252!!gm   remark, the ocean-ice stress is not saved in ice diag call above .....  find a solution!!! 
    255253      ! 
    256       IF( .NOT. wrk_release(3, 1,2) ) THEN 
    257          CALL ctl_stop( 'sbc_ice_lim: failed to release workspace arrays.' ) 
    258       END IF 
     254      IF( .NOT. wrk_release(3, 1,2) )   CALL ctl_stop( 'sbc_ice_lim: failed to release workspace arrays.' ) 
    259255      ! 
    260256   END SUBROUTINE sbc_ice_lim 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_lim_2.F90

    r2590 r2620  
    8484      !!--------------------------------------------------------------------- 
    8585      USE wrk_nemo, ONLY: wrk_use, wrk_release 
    86       USE wrk_nemo, ONLY: wrk_3d_1, wrk_3d_2, wrk_3d_3 
     86      USE wrk_nemo, ONLY: wrk_3d_1, wrk_3d_2, wrk_3d_3   ! 3D workspace 
    8787      !! 
    8888      INTEGER, INTENT(in) ::   kt      ! ocean time step 
    … …  
    9696      !!---------------------------------------------------------------------- 
    9797 
    98       IF(.NOT. wrk_use(3, 1,2,3))THEN 
    99          CALL ctl_stop('sbc_ice_lim_2: requested workspace arrays are unavailable.') 
    100          RETURN 
     98      IF(.NOT. wrk_use(3, 1,2,3) ) THEN 
     99         CALL ctl_stop('sbc_ice_lim_2: requested workspace arrays are unavailable.')   ;   RETURN 
    101100      END IF 
    102101      ! Use pointers to access only sub-arrays of workspaces 
    103102      zalb_ice_os => wrk_3d_1(:,:,1:1) 
    104103      zalb_ice_cs => wrk_3d_2(:,:,1:1) 
    105             zsist => wrk_3d_3(:,:,1:1) 
     104      zsist      => wrk_3d_3(:,:,1:1) 
    106105 
    107106      IF( kt == nit000 ) THEN 
    … …  
    204203         !                                             ! Ice surface fluxes in coupled mode  
    205204         IF( ksbc == 5 )   CALL sbc_cpl_ice_flx( reshape( frld, (/jpi,jpj,1/) ),                 & 
    206       &                                                   qns_tot, qns_ice, qsr_tot , qsr_ice,   & 
    207       &                                                   emp_tot, emp_ice, dqns_ice, sprecip,   & 
    208       !                                      optional arguments, used only in 'mixed oce-ice' case 
    209       &                                                   palbi = zalb_ice_cs, psst = sst_m, pist = sist ) 
     205            &                                             qns_tot, qns_ice, qsr_tot , qsr_ice,   & 
     206            &                                             emp_tot, emp_ice, dqns_ice, sprecip,   & 
     207            !                                optional arguments, used only in 'mixed oce-ice' case 
     208            &                                             palbi = zalb_ice_cs, psst = sst_m, pist = sist ) 
    210209#endif 
    211210                           CALL lim_thd_2      ( kt )      ! Ice thermodynamics  
    … …  
    229228      IF( ln_limdyn    )   CALL lim_sbc_tau_2( kt, ub(:,:,1), vb(:,:,1) )  ! using before instantaneous surf. currents 
    230229      ! 
    231       IF(.NOT. wrk_release(3, 1,2,3))THEN 
    232          CALL ctl_stop('sbc_ice_lim_2: failed to release workspace arrays.') 
    233       END IF 
     230      IF(.NOT. wrk_release(3, 1,2,3) )   CALL ctl_stop('sbc_ice_lim_2: failed to release workspace arrays') 
    234231      ! 
    235232   END SUBROUTINE sbc_ice_lim_2 
    … …  
    241238CONTAINS 
    242239   SUBROUTINE sbc_ice_lim_2 ( kt, ksbc )     ! Dummy routine 
    243       INTEGER, INTENT(in) ::   kt       
    244       INTEGER, INTENT(in) ::   ksbc     
     240      INTEGER, INTENT(in) ::   kt, ksbc     
    245241      WRITE(*,*) 'sbc_ice_lim_2: You should not have seen this print! error?', kt, ksbc 
    246242   END SUBROUTINE sbc_ice_lim_2 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/SBC/sbcmod.F90

    r2561 r2620  
    5757#  include "domzgr_substitute.h90" 
    5858   !!---------------------------------------------------------------------- 
    59    !! NEMO/OPA 3.3 , NEMO-consortium (2010)  
     59   !! NEMO/OPA 4.0 , NEMO-consortium (2011)  
    6060   !! $Id$ 
    61    !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
     61   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    6262   !!---------------------------------------------------------------------- 
    6363CONTAINS 
    … …  
    7676      INTEGER ::   icpt      ! temporary integer 
    7777      !! 
    78       NAMELIST/namsbc/ nn_fsbc, ln_ana  , ln_flx, ln_blk_clio, ln_blk_core, ln_cpl    ,   & 
    79          &             ln_apr_dyn, nn_ice , ln_dm2dc, ln_rnf, ln_ssr     , nn_fwb 
     78      NAMELIST/namsbc/ nn_fsbc   , ln_ana , ln_flx  , ln_blk_clio, ln_blk_core, ln_cpl,   & 
     79         &             ln_apr_dyn, nn_ice , ln_dm2dc, ln_rnf     , ln_ssr     , nn_fwb 
    8080      !!---------------------------------------------------------------------- 
    8181 
    … …  
    117117         WRITE(numout,*) '              closed sea (=0/1) (set in namdom)          nn_closea   = ', nn_closea 
    118118      ENDIF 
     119 
     120      !                              ! allocate sbc arrays 
     121      IF( sbc_oce_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'sbc_init : unable to allocate sbc_oce arrays' ) 
    119122 
    120123      !                          ! Checks: 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/SBC/sbcrnf.F90

    r2590 r2620  
    3030   PUBLIC   sbc_rnf       ! routine call in sbcmod module 
    3131   PUBLIC   sbc_rnf_div   ! routine called in sshwzv module 
    32    PUBLIC   sbc_rnf_alloc ! routine called in nemogcm module 
    33  
    34    !                                                      !!* namsbc_rnf namelist * 
     32 
     33   !                                                     !!* namsbc_rnf namelist * 
    3534   CHARACTER(len=100), PUBLIC ::   cn_dir       = './'    !: Root directory for location of ssr files 
    3635   LOGICAL           , PUBLIC ::   ln_rnf_depth = .false. !: depth       river runoffs attribute specified in a file 
    … …  
    4847   REAL(wp)          , PUBLIC ::   rn_rfact     = 1._wp   !: multiplicative factor for runoff 
    4948 
    50    INTEGER , PUBLIC                          ::   nkrnf = 0         !: nb of levels over which Kz is increased at river mouths 
    51    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   rnfmsk            !: river mouth mask (hori.) 
    52    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)     ::   rnfmsk_z          !: river mouth mask (vert.) 
    53    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   h_rnf             !: depth of runoff in m 
    54    INTEGER,  PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   nk_rnf            !: depth of runoff in model levels 
    55    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: rnf_tsc_b, rnf_tsc  !: before and now T & S contents of runoffs  [K.m/s & PSU.m/s] 
     49   INTEGER , PUBLIC  ::   nkrnf = 0         !: nb of levels over which Kz is increased at river mouths 
     50   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   rnfmsk              !: river mouth mask (hori.) 
     51   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)     ::   rnfmsk_z            !: river mouth mask (vert.) 
     52   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   h_rnf               !: depth of runoff in m 
     53   INTEGER,  PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   nk_rnf              !: depth of runoff in model levels 
     54   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   rnf_tsc_b, rnf_tsc  !: before and now T & S runoff contents   [K.m/s & PSU.m/s] 
    5655    
    5756   REAL(wp) ::   r1_rau0   ! = 1 / rau0  
    … …  
    7069CONTAINS 
    7170 
    72    FUNCTION sbc_rnf_alloc() 
     71   INTEGER FUNCTION sbc_rnf_alloc() 
    7372      !!---------------------------------------------------------------------- 
    7473      !!                ***  ROUTINE sbc_rnf_alloc  *** 
    7574      !!---------------------------------------------------------------------- 
    76       IMPLICIT none 
    77       INTEGER :: sbc_rnf_alloc 
    78       !!---------------------------------------------------------------------- 
    79  
    80       ALLOCATE(rnfmsk(jpi,jpj),         rnfmsk_z(jpk),         & 
    81                h_rnf(jpi,jpj),          nk_rnf(jpi,jpj),       & 
    82                rnf_tsc_b(jpi,jpj,jpts), rnf_tsc(jpi,jpj,jpts), & 
    83                Stat=sbc_rnf_alloc) 
    84  
    85       IF(sbc_rnf_alloc > 0)THEN 
    86          CALL ctl_warn('sbc_rnf_alloc: allocation of arrays failed.') 
    87       END IF 
    88  
     75      ALLOCATE( rnfmsk(jpi,jpj)         , rnfmsk_z(jpk)          ,     & 
     76         &      h_rnf (jpi,jpj)         , nk_rnf  (jpi,jpj)      ,     & 
     77         &      rnf_tsc_b(jpi,jpj,jpts) , rnf_tsc (jpi,jpj,jpts) , STAT=sbc_rnf_alloc) 
     78         ! 
     79      IF( lk_mpp            )   CALL mpp_sum ( sbc_rnf_alloc ) 
     80      IF( sbc_rnf_alloc > 0 )   CALL ctl_warn('sbc_rnf_alloc: allocation of arrays failed.') 
    8981   END FUNCTION sbc_rnf_alloc 
    9082 
    … …  
    296288      !                                   !   Type of runoff 
    297289      !                                   ! ================== 
     290      !                                         !==  allocate runoff arrays 
     291      IF( sbc_rnf_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'sbc_rnf_alloc : unable to allocate arrays' ) 
    298292      ! 
    299293      IF( ln_rnf_emp ) THEN                     !==  runoffs directly provided in the precipitations  ==! 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/SBC/sbcssm.F90

    r2528 r2620  
    44   !! Surface module :  provide time-mean ocean surface variables 
    55   !!====================================================================== 
    6    !! History :  9.0   !  06-07  (G. Madec)  Original code 
     6   !! History :  9.0  ! 2006-07  (G. Madec)  Original code 
    77   !!            3.3  ! 2010-10  (C. Bricaud, G. Madec)  add the Patm forcing for sea-ice 
    88   !!---------------------------------------------------------------------- 
    … …  
    3232   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    3333   !! $Id$ 
    34    !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
     34   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    3535   !!---------------------------------------------------------------------- 
    36  
    3736CONTAINS 
    3837 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/SBC/sbcssr.F90

    r2590 r2620  
    2525   PRIVATE 
    2626 
    27    PUBLIC   sbc_ssr       ! routine called in sbcmod 
    28    PUBLIC   sbc_ssr_alloc ! routine called in nemgcm 
    29  
    30    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   erp      !: evaporation damping   [kg/m2/s] 
    31    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   qrp      !: heat flux damping        [w/m2] 
     27   PUBLIC   sbc_ssr    ! routine called in sbcmod 
     28 
     29   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   erp   !: evaporation damping   [kg/m2/s] 
     30   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   qrp   !: heat flux damping        [w/m2] 
    3231 
    3332   !                                           !!* Namelist namsbc_ssr * 
    … …  
    4645#  include "domzgr_substitute.h90" 
    4746   !!---------------------------------------------------------------------- 
    48    !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
     47   !! NEMO/OPA 4.0 , NEMO Consortium (2011) 
    4948   !! $Id$ 
    50    !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    51    !!---------------------------------------------------------------------- 
    52  
     49   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
     50   !!---------------------------------------------------------------------- 
    5351CONTAINS 
    54  
    55    FUNCTION sbc_ssr_alloc() 
    56       !!--------------------------------------------------------------------- 
    57       !!                  ***  ROUTINE sbc_ssr_alloc  *** 
    58       !!--------------------------------------------------------------------- 
    59       IMPLICIT none 
    60       INTEGER :: sbc_ssr_alloc 
    61       !!--------------------------------------------------------------------- 
    62  
    63       ALLOCATE(erp(jpi,jpj), qrp(jpi,jpj), Stat=sbc_ssr_alloc) 
    64  
    65       IF(sbc_ssr_alloc > 0)THEN 
    66          CALL ctl_warn('sbc_ssr_alloc: allocation of arrays failed.') 
    67       END IF 
    68  
    69    END FUNCTION sbc_ssr_alloc 
    7052 
    7153   SUBROUTINE sbc_ssr( kt ) 
    … …  
    125107         ENDIF 
    126108 
    127          IF( nn_sstr == 1 ) THEN      !* set sf_sst structure 
     109         IF( nn_sstr == 1 ) THEN      !* set sf_sst structure & allocate arrays 
    128110            ! 
    129111            ALLOCATE( sf_sst(1), STAT=ierror ) 
    130             IF( ierror > 0 ) THEN 
    131                CALL ctl_stop( 'sbc_ssr: unable to allocate sf_sst structure' )   ;   RETURN 
    132             ENDIF 
    133             ALLOCATE( sf_sst(1)%fnow(jpi,jpj,1) ) 
     112            IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sst structure' ) 
     113            ALLOCATE( sf_sst(1)%fnow(jpi,jpj,1), STAT=ierror ) 
     114            IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sst now array' ) 
    134115            ! 
    135116            ! fill sf_sst with sn_sst and control print 
    136117            CALL fld_fill( sf_sst, (/ sn_sst /), cn_dir, 'sbc_ssr', 'SST restoring term toward SST data', 'namsbc_ssr' ) 
    137             IF( sf_sst(1)%ln_tint ) ALLOCATE( sf_sst(1)%fdta(jpi,jpj,1,2) ) 
    138          ENDIF 
    139          ! 
    140          IF( nn_sssr >= 1 ) THEN      ! set sf_sss structure 
     118            IF( sf_sst(1)%ln_tint )   ALLOCATE( sf_sst(1)%fdta(jpi,jpj,1,2), STAT=ierror ) 
     119            IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sst data array' ) 
     120            ! 
     121            ALLOCATE( qrp(jpi,jpj), STAT=ierror ) 
     122            IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate qrp array' ) 
     123         ENDIF 
     124         ! 
     125         IF( nn_sssr >= 1 ) THEN      ! set sf_sss structure & allocate arrays 
    141126            ! 
    142127            ALLOCATE( sf_sss(1), STAT=ierror ) 
    143             IF( ierror > 0 ) THEN 
    144                CALL ctl_stop( 'sbc_ssr: unable to allocate sf_sss structure' )   ;   RETURN 
    145             ENDIF 
    146             ALLOCATE( sf_sss(1)%fnow(jpi,jpj,1) ) 
     128            IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sss structure' ) 
     129            ALLOCATE( sf_sss(1)%fnow(jpi,jpj,1), STAT=ierror ) 
     130            IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sss now array' ) 
    147131            ! 
    148132            ! fill sf_sss with sn_sss and control print 
    149133            CALL fld_fill( sf_sss, (/ sn_sss /), cn_dir, 'sbc_ssr', 'SSS restoring term toward SSS data', 'namsbc_ssr' ) 
    150             IF( sf_sss(1)%ln_tint )ALLOCATE( sf_sss(1)%fdta(jpi,jpj,1,2) ) 
     134            IF( sf_sss(1)%ln_tint )   ALLOCATE( sf_sss(1)%fdta(jpi,jpj,1,2), STAT=ierror ) 
     135            IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sss data array' ) 
     136            ! 
     137            ALLOCATE( erp(jpi,jpj), STAT=ierror ) 
     138            IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate erp array' ) 
    151139         ENDIF 
    152140         ! 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90

    r2618 r2620  
    472472      
    473473     USE dynzdf_exp,   ONLY: dyn_zdf_exp_alloc 
    474      USE geo2ocean,    ONLY: geo2oce_alloc 
    475474#if   defined key_mpp_mpi   
    476475     USE lib_mpp,      ONLY: lib_mpp_alloc 
    … …  
    480479     USE obc_oce,      ONLY: obc_oce_alloc 
    481480#endif 
    482      USE sbcblk_clio,  ONLY: sbc_blk_clio_alloc 
    483 #if defined key_oasis3 || defined key_oasis4 
    484      USE sbccpl,       ONLY: sbc_cpl_init_alloc 
    485 #endif 
    486      USE sbcdcy,       ONLY: sbc_dcy_alloc 
    487      USE sbcfwb,       ONLY: sbc_fwb_alloc 
    488      USE sbc_oce,      ONLY: sbc_oce_alloc 
    489      USE sbcrnf,       ONLY: sbc_rnf_alloc 
    490      USE sbcssr,       ONLY: sbc_ssr_alloc 
     481 
    491482     USE sol_oce,      ONLY: sol_oce_alloc 
    492483     USE solmat,       ONLY: sol_mat_alloc 
    … …  
    565556 
    566557      ierr = ierr + dyn_zdf_exp_alloc() 
    567       ierr = ierr + geo2oce_alloc() 
    568558#if defined key_mpp_mpi  
    569559      ierr = ierr + lib_mpp_alloc() 
    … …  
    573563      ierr = ierr + obc_oce_alloc() 
    574564#endif 
    575       ierr = ierr + sbc_blk_clio_alloc() 
    576 #if defined key_oasis3 || defined key_oasis4 
    577       ierr = ierr + sbc_cpl_init_alloc() 
    578 #endif 
    579       ierr = ierr + sbc_dcy_alloc() 
    580       ierr = ierr + sbc_fwb_alloc() 
    581       ierr = ierr + sbc_oce_alloc() 
    582       ierr = ierr + sbc_rnf_alloc() 
    583       ierr = ierr + sbc_ssr_alloc() 
     565 
    584566      ierr = ierr + sol_oce_alloc() 
    585567      ierr = ierr + sol_mat_alloc() 
    … …  
    763745      RETURN 
    764746      ! 
    765   END SUBROUTINE factorise 
    766  
    767   !!====================================================================== 
     747   END SUBROUTINE factorise 
     748 
     749   !!====================================================================== 
    768750END MODULE nemogcm 
Note: See TracChangeset for help on using the changeset viewer.