- Timestamp:
- 2011-02-26T13:31:38+01:00 (13 years ago)
- Location:
- branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC
- Files:
-
- 28 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/DIA/diahth.F90
r2613 r2618 57 57 ! 58 58 END FUNCTION dia_hth_alloc 59 59 60 60 61 SUBROUTINE dia_hth( kt ) … … 104 105 105 106 IF( kt == nit000 ) THEN 107 ! ! allocate dia_hth array 108 IF( dia_hth_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'lim_sbc_init : unable to allocate standard arrays' ) 106 109 107 110 IF(.not. ALLOCATED(ik20))THEN 108 111 ALLOCATE(ik20(jpi,jpj), ik28(jpi,jpj), & 109 zabs2(jpi,jpj), &110 ztm2(jpi,jpj), &111 zrho10_3(jpi,jpj),&112 zpycn(jpi,jpj), &113 ztinv(jpi,jpj), &114 zdepinv(jpi,jpj), &115 zrho0_3(jpi,jpj), &116 zrho0_1(jpi,jpj), &117 zmaxdzT(jpi,jpj), &118 zthick(jpi,jpj), &119 zdelr(jpi,jpj), STAT=ji)112 & zabs2(jpi,jpj), & 113 & ztm2(jpi,jpj), & 114 & zrho10_3(jpi,jpj),& 115 & zpycn(jpi,jpj), & 116 & ztinv(jpi,jpj), & 117 & zdepinv(jpi,jpj), & 118 & zrho0_3(jpi,jpj), & 119 & zrho0_1(jpi,jpj), & 120 & zmaxdzT(jpi,jpj), & 121 & zthick(jpi,jpj), & 122 & zdelr(jpi,jpj), STAT=ji) 120 123 IF( lk_mpp ) CALL mpp_sum(ji) 121 124 IF( ji /= 0 ) CALL ctl_stop( 'STOP', 'dia_hth : unable to allocate standard ocean arrays' ) -
branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/DIA/diaptr.F90
r2590 r2618 41 41 PUBLIC ptr_vj ! call by tra_ldf & tra_adv routines 42 42 PUBLIC ptr_vjk ! call by tra_ldf & tra_adv routines 43 PUBLIC dia_ptr_alloc ! call in nemogcm module44 43 45 44 ! !!** namelist namptr ** … … 51 50 INTEGER , PUBLIC :: nn_fwri = 15 !: frequency of ptr outputs [time step] 52 51 53 REAL(wp), PUBLIC, DIMENSION(:), ALLOCATABLE:: htr_adv, htr_ldf, htr_ove !: Heat TRansports (adv, diff, overturn.)54 REAL(wp), PUBLIC, DIMENSION(:), ALLOCATABLE:: str_adv, str_ldf, str_ove !: Salt TRansports (adv, diff, overturn.)52 REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:) :: htr_adv, htr_ldf, htr_ove !: Heat TRansports (adv, diff, overturn.) 53 REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:) :: str_adv, str_ldf, str_ove !: Salt TRansports (adv, diff, overturn.) 55 54 56 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: btmsk ! T-point basin interior masks 57 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: btm30 ! mask out Southern Ocean (=0 south of 30°S) 58 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: htr , str ! adv heat and salt transports (approx) 59 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: tn_jk, sn_jk , v_msf ! i-mean T and S, j-Stream-Function 60 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: sjk , r1_sjk ! i-mean i-k-surface and its inverse 61 #if defined key_diaeiv 62 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: htr_eiv, str_eiv ! bolus adv heat ans salt transports ('key_diaeiv') 63 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: v_msf_eiv ! bolus j-streamfuction ('key_diaeiv') 64 #endif 55 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: btmsk ! T-point basin interior masks 56 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: btm30 ! mask out Southern Ocean (=0 south of 30°S) 57 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: htr , str ! adv heat and salt transports (approx) 58 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: tn_jk, sn_jk , v_msf ! i-mean T and S, j-Stream-Function 59 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sjk , r1_sjk ! i-mean i-k-surface and its inverse 60 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: htr_eiv, str_eiv ! bolus adv heat ans salt transports ('key_diaeiv') 61 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: v_msf_eiv ! bolus j-streamfuction ('key_diaeiv') 62 65 63 66 64 INTEGER :: niter ! … … 78 76 !! Integer, 1D workspace arrays. Not common enough to be implemented in 79 77 !! wrk_nemo module. 80 INTEGER, ALLOCATABLE, SAVE, DIMENSION 81 INTEGER, ALLOCATABLE, SAVE, DIMENSION 82 INTEGER, ALLOCATABLE, SAVE, DIMENSION 78 INTEGER, ALLOCATABLE, SAVE, DIMENSION(:) :: ndex , ndex_atl , ndex_pac , ndex_ind , ndex_ipc 79 INTEGER, ALLOCATABLE, SAVE, DIMENSION(:) :: ndex_atl_30 , ndex_pac_30 , ndex_ind_30 , ndex_ipc_30 80 INTEGER, ALLOCATABLE, SAVE, DIMENSION(:) :: ndex_h, ndex_h_atl_30, ndex_h_pac_30, ndex_h_ind_30, ndex_h_ipc_30 83 81 84 82 !! * Substitutions … … 92 90 CONTAINS 93 91 94 92 FUNCTION dia_ptr_alloc() 95 93 !!---------------------------------------------------------------------- 96 94 !! *** ROUTINE dia_ptr_alloc *** 97 95 !!---------------------------------------------------------------------- 98 INTEGER :: dia_ptr_alloc99 INTEGER, DIMENSION(5) :: ierr96 INTEGER :: dia_ptr_alloc ! return value 97 INTEGER, DIMENSION(5) :: ierr 100 98 !!---------------------------------------------------------------------- 101 99 … … 103 101 104 102 ALLOCATE( btmsk(jpi,jpj,nptr) , & 105 htr_adv(jpj) , str_adv(jpj) , &106 htr_ldf(jpj) , str_ldf(jpj) , &107 htr_ove(jpj) , str_ove(jpj), &108 htr(jpj,nptr) , str(jpj,nptr) , &109 tn_jk(jpj,jpk,nptr) , sn_jk (jpj,jpk,nptr) , v_msf(jpj,jpk,nptr) , &110 sjk (jpj,jpk,nptr) , r1_sjk(jpj,jpk,nptr) , STAT=ierr(1) )103 & htr_adv(jpj) , str_adv(jpj) , & 104 & htr_ldf(jpj) , str_ldf(jpj) , & 105 & htr_ove(jpj) , str_ove(jpj), & 106 & htr(jpj,nptr) , str(jpj,nptr) , & 107 & tn_jk(jpj,jpk,nptr) , sn_jk (jpj,jpk,nptr) , v_msf(jpj,jpk,nptr) , & 108 & sjk (jpj,jpk,nptr) , r1_sjk(jpj,jpk,nptr) , STAT=ierr(1) ) 111 109 ! 112 110 #if defined key_diaeiv 113 111 ALLOCATE( htr_eiv(jpj,nptr) , str_eiv(jpj,nptr) , & 114 112 & v_msf_eiv(jpj,jpk,nptr) , STAT=ierr(2) ) 115 113 #endif 116 114 … … 118 116 119 117 ALLOCATE(ndex(jpj*jpk), ndex_atl(jpj*jpk), ndex_pac(jpj*jpk), & 120 121 118 & ndex_ind(jpj*jpk), ndex_ipc(jpj*jpk), & 119 & ndex_atl_30(jpj*jpk), ndex_pac_30(jpj*jpk), Stat=ierr(4)) 122 120 123 121 ALLOCATE(ndex_ind_30(jpj*jpk), ndex_ipc_30(jpj*jpk), & 124 ndex_h(jpj), ndex_h_atl_30(jpj), ndex_h_pac_30(jpj), & 125 ndex_h_ind_30(jpj), ndex_h_ipc_30(jpj), Stat=ierr(5)) 126 127 dia_ptr_alloc = MAXVAL(ierr) 128 122 & ndex_h(jpj), ndex_h_atl_30(jpj), ndex_h_pac_30(jpj), & 123 & ndex_h_ind_30(jpj), ndex_h_ipc_30(jpj), Stat=ierr(5) ) 124 ! 125 dia_ptr_alloc = MAXVAL( ierr ) 126 IF(lk_mpp) CALL mpp_sum( dia_ptr_alloc ) 127 ! 129 128 END FUNCTION dia_ptr_alloc 130 129 … … 141 140 !! ** Action : - p_fval: i-k-mean poleward flux of pva 142 141 !!---------------------------------------------------------------------- 143 IMPLICIT none144 142 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) :: pva ! mask flux array at V-point 145 143 !! … … 160 158 END DO 161 159 END DO 162 ! 163 #if defined key_mpp_mpi 164 CALL mpp_sum( p_fval, ijpj, ncomm_znl) 160 #if defined key_mpp_mpi 161 IF(lk_mpp) CALL mpp_sum( p_fval, ijpj, ncomm_znl) 165 162 #endif 166 163 ! … … 196 193 END DO 197 194 END DO 198 !199 195 #if defined key_mpp_mpi 200 196 CALL mpp_sum( p_fval, ijpj, ncomm_znl ) … … 234 230 ! 235 231 #if defined key_mpp_mpi 236 IF(.not. wrk_use(1, 1))THEN 237 CALL ctl_stop('ptr_vjk: ERROR - requested workspace array is unavailable') 238 RETURN 232 IF( .not. wrk_use(1, 1) ) THEN 233 CALL ctl_stop('ptr_vjk: ERROR - requested workspace array is unavailable') ; RETURN 239 234 END IF 240 235 #endif … … 272 267 ! 273 268 #if defined key_mpp_mpi 274 IF(.not. wrk_release(1, 1))THEN 275 CALL ctl_stop('ptr_vjk: ERROR - failed to release workspace array') 276 END IF 269 IF(.NOT. wrk_release(1, 1) ) CALL ctl_stop('ptr_vjk: ERROR - failed to release workspace array') 277 270 #endif 278 271 ! … … 333 326 ! 334 327 #if defined key_mpp_mpi 335 IF(.NOT. wrk_release(1, 1))THEN 336 CALL ctl_stop('ptr_tjk: failed to release workspace array.') 337 END IF 328 IF( .NOT. wrk_release(1, 1) ) CALL ctl_stop('ptr_tjk: failed to release workspace array.') 338 329 #endif 339 330 ! … … 461 452 NAMELIST/namptr/ ln_diaptr, ln_diaznl, ln_subbas, ln_ptrcomp, nn_fptr, nn_fwri 462 453 !!---------------------------------------------------------------------- 454 455 ! ! allocate dia_ptr arrays 456 IF( dia_ptr_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'lim_sbc_init : unable to allocate arrays' ) 463 457 464 458 REWIND( numnam ) ! Read Namelist namptr : poleward transport parameters … … 547 541 !! 548 542 INTEGER, SAVE :: nhoridz, ndepidzt, ndepidzw 549 INTEGER, SAVE :: ndim , ndim_atl , ndim_pac , ndim_ind , ndim_ipc550 INTEGER, SAVE :: ndim_atl_30 , ndim_pac_30 , ndim_ind_30 , ndim_ipc_30551 INTEGER, SAVE :: ndim_h, ndim_h_atl_30, ndim_h_pac_30, ndim_h_ind_30, ndim_h_ipc_30552 !! 553 CHARACTER (len=40) 554 INTEGER 543 INTEGER, SAVE :: ndim , ndim_atl , ndim_pac , ndim_ind , ndim_ipc 544 INTEGER, SAVE :: ndim_atl_30 , ndim_pac_30 , ndim_ind_30 , ndim_ipc_30 545 INTEGER, SAVE :: ndim_h, ndim_h_atl_30, ndim_h_pac_30, ndim_h_ind_30, ndim_h_ipc_30 546 !! 547 CHARACTER (len=40) :: clhstnam, clop, clop_once, cl_comment ! temporary names 548 INTEGER :: iline, it, itmod, ji, jj, jk ! 555 549 #if defined key_iomput 556 INTEGER 557 #endif 558 REAL(wp) 550 INTEGER :: inum ! temporary logical unit 551 #endif 552 REAL(wp) :: zsto, zout, zdt, zjulian ! temporary scalars 559 553 !!---------------------------------------------------------------------- 560 554 561 555 IF( (.not. wrk_use(1, 1,2)) .OR. (.not. wrk_use(2, 1)) )THEN 562 CALL ctl_stop('dia_ptr_wri: ERROR: requested workspace arrays unavailable') 563 RETURN 556 CALL ctl_stop('dia_ptr_wri: ERROR: requested workspace arrays unavailable') ; RETURN 564 557 END IF 565 558 … … 641 634 zfoo(1:jpj) = 0._wp 642 635 643 ! Compute julian date from starting date of the run 644 645 CALL ymds2ju( nyear, nmonth, nday, rdt, zjulian ) 646 zjulian = zjulian - adatrj ! set calendar origin to the beginning of the experiment 636 CALL ymds2ju( nyear, nmonth, nday, rdt, zjulian ) ! Compute julian date from starting date of the run 637 zjulian = zjulian - adatrj ! set calendar origin to the beginning of the experiment 647 638 648 639 #if defined key_iomput … … 667 658 CALL histvert( numptr, "depthw", "Vertical W levels", & 668 659 & "m", jpk, gdepw_0, ndepidzw, "down" ) 669 670 660 ! 671 661 CALL wheneq ( jpj*jpk, MIN(sjk(:,:,1), 1._wp), 1, 1., ndex , ndim ) ! Lat-Depth … … 701 691 cl_comment = ' ' 702 692 #endif 703 ! Zonal mean T and S 704 705 IF( ln_diaznl ) THEN 693 IF( ln_diaznl ) THEN ! Zonal mean T and S 706 694 CALL histdef( numptr, "zotemglo", "Zonal Mean Temperature","C" , & 707 695 1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout ) … … 711 699 CALL histdef( numptr, "zosrfglo", "Zonal Mean Surface","m^2" , & 712 700 1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout ) 713 701 ! 714 702 IF (ln_subbas) THEN 715 703 CALL histdef( numptr, "zotematl", "Zonal Mean Temperature: Atlantic","C" , & … … 741 729 1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout ) 742 730 ENDIF 743 744 731 ENDIF 745 732 ! 746 733 ! Meridional Stream-Function (Eulerian and Bolus) 747 748 734 CALL histdef( numptr, "zomsfglo", "Meridional Stream-Function: Global"//TRIM(cl_comment),"Sv" , & 749 735 1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout ) … … 758 744 1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout ) 759 745 ENDIF 760 746 ! 761 747 ! Heat transport 762 763 748 CALL histdef( numptr, "sophtadv", "Advective Heat Transport" , & 764 749 "PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) … … 779 764 "PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 780 765 ENDIF 781 782 766 ! 783 767 ! Salt transport 784 785 768 CALL histdef( numptr, "sopstadv", "Advective Salt Transport" , & 786 769 "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) … … 810 793 "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 811 794 ENDIF 812 795 ! 813 796 CALL histend( numptr ) 814 797 ! 815 798 END IF 816 799 #if defined key_mpp_mpi … … 886 869 ENDIF 887 870 ! 888 IF( (.not. wrk_release(1, 1,2)) .OR. (.not. wrk_release(2, 1)) )THEN 889 CALL ctl_stop('dia_ptr_wri: ERROR: failed to release workspace arrays') 890 END IF 871 IF( .not. wrk_release(1, 1,2) .OR. (.not. wrk_release(2, 1)) ) & 872 CALL ctl_stop('dia_ptr_wri: failed to release workspace arrays') 891 873 ! 892 874 END SUBROUTINE dia_ptr_wri -
branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/DOM/dom_oce.F90
r2590 r2618 7 7 !! History : 1.0 ! 2005-10 (A. Beckmann, G. Madec) reactivate s-coordinate 8 8 !! 3.3 ! 2010-11 (G. Madec) add mbk. arrays associated to the deepest ocean level 9 !!---------------------------------------------------------------------- 10 USE par_oce ! ocean parameters 9 !! 4.0 ! 2011-01 (A. R. Porter, STFC Daresbury) dynamical allocation 10 !!---------------------------------------------------------------------- 11 12 !!---------------------------------------------------------------------- 13 !! Agrif_Root : dummy function used when lk_agrif=F 14 !! Agrif_CFixed : dummy function used when lk_agrif=F 15 !! dom_oce_alloc : dynamical allocation of dom_oce arrays 16 !!---------------------------------------------------------------------- 17 USE par_oce ! ocean parameters 11 18 12 19 IMPLICIT NONE 13 PUBLIC ! allows the acces to par_oce when dom_oce is used 14 ! ! exception to coding rules... to be suppressed ??? 20 PUBLIC ! allows the acces to par_oce when dom_oce is used 21 ! ! exception to coding rules... to be suppressed ??? 22 23 PUBLIC dom_oce_alloc ! Called from nemogcm.F90 15 24 16 25 !!---------------------------------------------------------------------- … … 44 53 REAL(wp), PUBLIC :: rdth !: depth variation of tracer step 45 54 INTEGER , PUBLIC :: nclosea !: =0 suppress closed sea/lake from the ORCA domain or not (=1) 46 47 55 48 56 ! !!! associated variables … … 216 224 #endif 217 225 218 PUBLIC dom_oce_alloc ! Called from nemogcm.F90219 220 226 !!---------------------------------------------------------------------- 221 227 !! agrif domain … … 227 233 #endif 228 234 235 !!---------------------------------------------------------------------- 236 !! NEMO/OPA 4.0 , NEMO Consortium (2011) 237 !! $Id$ 238 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 239 !!---------------------------------------------------------------------- 229 240 CONTAINS 230 241 231 242 #if ! defined key_agrif 243 !!---------------------------------------------------------------------- 244 !! NOT 'key_agrif' dummy function No AGRIF zoom 245 !!---------------------------------------------------------------------- 232 246 LOGICAL FUNCTION Agrif_Root() 233 247 Agrif_Root = .TRUE. … … 235 249 236 250 CHARACTER(len=3) FUNCTION Agrif_CFixed() 237 Agrif_CFixed = '0'251 Agrif_CFixed = '0' 238 252 END FUNCTION Agrif_CFixed 239 253 #endif 240 254 241 FUNCTION dom_oce_alloc() 242 !!---------------------------------------------------------------------- 243 USE par_oce, Only: jpi, jpj, jpk, jpnij 244 IMPLICIT none 245 INTEGER :: dom_oce_alloc 246 INTEGER, DIMENSION(11) :: ierr 247 248 ierr(:) = 0 249 250 ALLOCATE(rdttra(jpk), mig(jpi), mjg(jpj), Stat=ierr(1)) 251 252 ALLOCATE(nimppt(jpnij), njmppt(jpnij), & 253 ibonit(jpnij), ibonjt(jpnij), & 254 nlcit(jpnij), nlcjt(jpnij), & 255 nldit(jpnij), nldjt(jpnij), & 256 nleit(jpnij), nlejt(jpnij), Stat=ierr(2)) 257 258 ALLOCATE(glamt(jpi,jpj), glamu(jpi,jpj), & 259 glamv(jpi,jpj), glamf(jpi,jpj), & 260 gphit(jpi,jpj), gphiu(jpi,jpj), & 261 gphiv(jpi,jpj), gphif(jpi,jpj), & 262 e1t(jpi,jpj), e2t(jpi,jpj), & 263 e1u(jpi,jpj), e2u(jpi,jpj), & 264 e1v(jpi,jpj), e2v(jpi,jpj), & 265 e1f(jpi,jpj), e2f(jpi,jpj), & 266 ff(jpi,jpj), Stat=ierr(3)) 267 268 !IF( .not. lk_zco )THEN 269 ALLOCATE(gdep3w(jpi,jpj,jpk), & 270 gdept(jpi,jpj,jpk) , gdepw(jpi,jpj,jpk), & 271 e3v(jpi,jpj,jpk) , e3f(jpi,jpj,jpk) , & 272 e3t(jpi,jpj,jpk) , e3u(jpi,jpj,jpk) , & 273 e3vw(jpi,jpj,jpk) , & 274 e3w(jpi,jpj,jpk) , e3uw(jpi,jpj,jpk) , Stat=ierr(4)) 275 !END IF 255 INTEGER FUNCTION dom_oce_alloc() 256 !!---------------------------------------------------------------------- 257 INTEGER, DIMENSION(11) :: ierr 258 !!---------------------------------------------------------------------- 259 260 ierr(:) = 0 261 262 ALLOCATE( rdttra(jpk), mig(jpi), mjg(jpj), STAT=ierr(1) ) 263 264 ALLOCATE( nimppt(jpnij) , ibonit(jpnij) , nlcit(jpnij) , nlcjt(jpnij) , & 265 & njmppt(jpnij) , ibonjt(jpnij) , nldit(jpnij) , nldjt(jpnij) , & 266 & nleit(jpnij) , nlejt(jpnij) , STAT=ierr(2) ) 267 268 ALLOCATE( glamt(jpi,jpj), gphit(jpi,jpj), e1t(jpi,jpj), e2t(jpi,jpj), & 269 & glamu(jpi,jpj), gphiu(jpi,jpj), e1u(jpi,jpj), e2u(jpi,jpj), & 270 & glamv(jpi,jpj), gphiv(jpi,jpj), e1v(jpi,jpj), e2v(jpi,jpj), & 271 & glamf(jpi,jpj), gphif(jpi,jpj), e1f(jpi,jpj), e2f(jpi,jpj), ff(jpi,jpj), STAT=ierr(3) ) 272 273 ALLOCATE( gdep3w(jpi,jpj,jpk) , e3v(jpi,jpj,jpk) , e3f (jpi,jpj,jpk) , & 274 & gdept (jpi,jpj,jpk) , e3t(jpi,jpj,jpk) , e3u (jpi,jpj,jpk) , & 275 & gdepw (jpi,jpj,jpk) , e3w(jpi,jpj,jpk) , e3vw(jpi,jpj,jpk) , e3uw(jpi,jpj,jpk) , STAT=ierr(4) ) 276 276 277 277 #if defined key_vvl 278 ALLOCATE(gdep3w_1(jpi,jpj,jpk) , & 279 gdept_1(jpi,jpj,jpk), gdepw_1(jpi,jpj,jpk), & 280 e3v_1(jpi,jpj,jpk) , e3f_1(jpi,jpj,jpk) , & 281 e3t_1(jpi,jpj,jpk) , e3u_1(jpi,jpj,jpk) , & 282 e3vw_1(jpi,jpj,jpk) , & 283 e3w_1(jpi,jpj,jpk) , e3uw_1(jpi,jpj,jpk), & 284 e3t_b(jpi,jpj,jpk) , & 285 e3u_b(jpi,jpj,jpk) , e3v_b(jpi,jpj,jpk), & 286 Stat=ierr(5)) 287 #endif 288 289 ALLOCATE(hur(jpi,jpj), hvr(jpi,jpj), & 290 hu(jpi,jpj), hv(jpi,jpj), & 291 hu_0(jpi,jpj), hv_0(jpi,jpj),& 292 Stat=ierr(6)) 278 ALLOCATE( gdep3w_1(jpi,jpj,jpk) , e3v_1(jpi,jpj,jpk) , e3f_1 (jpi,jpj,jpk) , & 279 & gdept_1 (jpi,jpj,jpk) , e3t_1(jpi,jpj,jpk) , e3u_1 (jpi,jpj,jpk) , & 280 & gdepw_1 (jpi,jpj,jpk) , e3w_1(jpi,jpj,jpk) , e3vw_1(jpi,jpj,jpk) , e3uw_1(jpi,jpj,jpk) , & 281 & e3t_b (jpi,jpj,jpk) , e3u_b(jpi,jpj,jpk) , e3v_b(jpi,jpj,jpk) , STAT=ierr(5) ) 282 #endif 283 284 ALLOCATE( hu(jpi,jpj) , hur(jpi,jpj) , hu_0(jpi,jpj) , & 285 & hv(jpi,jpj) , hvr(jpi,jpj) , hv_0(jpi,jpj) , STAT=ierr(6) ) 286 287 ALLOCATE( gdept_0(jpk) , gdepw_0(jpk) , & 288 & e3t_0 (jpk) , e3w_0 (jpk) , e3tp (jpi,jpj), e3wp(jpi,jpj) , & 289 & gsigt (jpk) , gsigw (jpk) , gsi3w(jpk) , & 290 & esigt (jpk) , esigw (jpk) , STAT=ierr(7) ) 293 291 ! 294 ALLOCATE(gdept_0(jpk), gdepw_0(jpk), e3t_0(jpk), & 295 e3w_0(jpk) , e3tp(jpi,jpj), e3wp(jpi,jpj), & 296 gsigt(jpk) , gsigw(jpk) , gsi3w(jpk), & 297 esigt(jpk) , esigw(jpk) , Stat=ierr(7)) 298 ! 299 ALLOCATE(hbatv(jpi,jpj) , hbatf(jpi,jpj) , & 300 hbatt(jpi,jpj) , hbatu(jpi,jpj) , & 301 scosrf(jpi,jpj), scobot(jpi,jpj), & 302 hifv(jpi,jpj) , hiff(jpi,jpj) , & 303 hift(jpi,jpj) , hifu(jpi,jpj) , & 304 Stat=ierr(8)) 305 ! 306 ALLOCATE(mbathy(jpi,jpj), & 307 mbkt(jpi,jpj), mbku(jpi,jpj), mbkv(jpi,jpj), & 308 bathy(jpi,jpj), & 309 tmask_i(jpi,jpj),bmask(jpi,jpj), & 310 Stat=ierr(9)) 311 312 ALLOCATE(tmask(jpi,jpj,jpk), umask(jpi,jpj,jpk), & 313 vmask(jpi,jpj,jpk), fmask(jpi,jpj,jpk), & 314 Stat=ierr(10)) 292 ALLOCATE( hbatv (jpi,jpj) , hbatf (jpi,jpj) , & 293 & hbatt (jpi,jpj) , hbatu (jpi,jpj) , & 294 & scosrf(jpi,jpj) , scobot(jpi,jpj) , & 295 & hifv (jpi,jpj) , hiff (jpi,jpj) , & 296 & hift (jpi,jpj) , hifu (jpi,jpj) , STAT=ierr(8) ) 297 298 ALLOCATE( mbathy(jpi,jpj) , bathy(jpi,jpj) , & 299 & tmask_i(jpi,jpj) , bmask(jpi,jpj) , & 300 & mbkt (jpi,jpj) , mbku (jpi,jpj) , mbkv(jpi,jpj) , STAT=ierr(9) ) 301 302 ALLOCATE( tmask(jpi,jpj,jpk), umask(jpi,jpj,jpk), & 303 & vmask(jpi,jpj,jpk), fmask(jpi,jpj,jpk), STAT=ierr(10) ) 315 304 316 305 #if defined key_noslip_accurate 317 ALLOCATE(npcoa(4,jpk), nicoa(2*(jpi+jpj),4,jpk), njcoa(2*(jpi+jpj),4,jpk), & 318 Stat=ierr(11)) 319 #endif 320 321 dom_oce_alloc = MAXVAL(ierr) 322 323 END FUNCTION dom_oce_alloc 324 325 !!---------------------------------------------------------------------- 326 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 327 !! $Id$ 328 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 306 ALLOCATE( npcoa(4,jpk), nicoa(2*(jpi+jpj),4,jpk), njcoa(2*(jpi+jpj),4,jpk), STAT=ierr(11) ) 307 #endif 308 ! 309 dom_oce_alloc = MAXVAL(ierr) 310 ! 311 END FUNCTION dom_oce_alloc 312 329 313 !!====================================================================== 330 314 END MODULE dom_oce -
branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/DOM/domvvl.F90
r2590 r2618 27 27 PUBLIC dom_vvl_alloc ! called by nemogcm.F90 28 28 29 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:):: ee_t, ee_u, ee_v, ee_f !: ???30 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: mut , muu, muv, muf!: ???31 32 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:):: r2dt ! vertical profile time-step, = 2 rdttra33 ! ! except at nit000 (=rdttra) if neuler=029 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ee_t, ee_u, ee_v, ee_f !: ??? 30 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: mut , muu , muv , muf !: ??? 31 32 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: r2dt ! vertical profile time-step, = 2 rdttra 33 ! ! except at nit000 (=rdttra) if neuler=0 34 34 35 35 !! * Substitutions … … 37 37 # include "vectopt_loop_substitute.h90" 38 38 !!---------------------------------------------------------------------- 39 !! NEMO/OPA 3.3 , NEMO Consortium (2010)39 !! NEMO/OPA 4.0 , NEMO Consortium (2011) 40 40 !! $Id$ 41 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 42 !!---------------------------------------------------------------------- 43 41 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 42 !!---------------------------------------------------------------------- 44 43 CONTAINS 45 44 46 FUNCTION dom_vvl_alloc()45 INTEGER FUNCTION dom_vvl_alloc() 47 46 !!---------------------------------------------------------------------- 48 47 !! *** ROUTINE dom_vvl_alloc *** 49 48 !!---------------------------------------------------------------------- 50 IMPLICIT none 51 INTEGER :: dom_vvl_alloc 52 !!---------------------------------------------------------------------- 53 54 ALLOCATE(mut(jpi,jpj,jpk), muu(jpi,jpj,jpk), muv(jpi,jpj,jpk), & 55 muf(jpi,jpj,jpk), & 56 ee_t(jpi,jpj), ee_u(jpi,jpj), ee_v(jpi,jpj), ee_f(jpi,jpj), & 57 r2dt(jpk), Stat=dom_vvl_alloc) 58 59 IF(dom_vvl_alloc /= 0)THEN 60 CALL ctl_warn('dom_vvl_alloc: failed to allocate arrays') 61 END IF 62 49 ! 50 ALLOCATE( mut (jpi,jpj,jpk) , muu (jpi,jpj,jpk) , muv (jpi,jpj,jpk) , muf (jpi,jpj,jpk) , & 51 & ee_t(jpi,jpj) , ee_u(jpi,jpj) , ee_v(jpi,jpj) , ee_f(jpi,jpj) , & 52 & r2dt(jpk) , STAT=dom_vvl_alloc) 53 ! 54 IF( lk_mpp ) CALL mpp_sum ( dom_vvl_alloc ) 55 IF( dom_vvl_alloc /= 0 ) CALL ctl_warn('dom_vvl_alloc: failed to allocate arrays') 56 ! 63 57 END FUNCTION dom_vvl_alloc 64 58 … … 71 65 !! ssh over the whole water column (scale factors) 72 66 !!---------------------------------------------------------------------- 73 USE wrk_nemo, ONLY: wrk_use, wrk_release74 USE wrk_nemo, ONLY: zs_t => wrk_2d_1, zs_u_1 => wrk_2d_2, &75 67 USE wrk_nemo, ONLY: wrk_use, wrk_release 68 USE wrk_nemo, ONLY: zs_t => wrk_2d_1, zs_u_1 => wrk_2d_2 69 USE wrk_nemo, ONLY: zs_v_1 => wrk_2d_3 76 70 !! 77 71 INTEGER :: ji, jj, jk 78 REAL(wp) :: zcoefu , zcoefv , zcoeff ! temporaryscalars79 REAL(wp) :: zv_t_ij, zv_t_ip1j, zv_t_ijp1, zv_t_ip1jp1 ! --72 REAL(wp) :: zcoefu , zcoefv , zcoeff ! local scalars 73 REAL(wp) :: zv_t_ij, zv_t_ip1j, zv_t_ijp1, zv_t_ip1jp1 ! - - 80 74 !!---------------------------------------------------------------------- 81 75 82 76 IF(.not. wrk_use(2, 1,2,3))THEN 83 CALL ctl_stop('dom_vvl: ERROR - requested workspace arrays unavailable.') 84 RETURN 77 CALL ctl_stop('dom_vvl: ERROR - requested workspace arrays unavailable.') ; RETURN 85 78 END IF 86 79 87 IF(lwp) 80 IF(lwp) THEN 88 81 WRITE(numout,*) 89 WRITE(numout,*) 'dom_vvl : Variable volume activated'82 WRITE(numout,*) 'dom_vvl : Variable volume initialization' 90 83 WRITE(numout,*) '~~~~~~~~ compute coef. used to spread ssh over each layers' 91 84 ENDIF 92 85 86 IF( dom_vvl_alloc /= 0 ) CALL ctl_stop( 'STOP', 'dom_vvl : unable to allocate arrays' ) 93 87 94 88 fsdept(:,:,:) = gdept (:,:,:) -
branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/DOM/domwri.F90
r2590 r2618 2 2 !!====================================================================== 3 3 !! *** MODULE domwri *** 4 !! Ocean initialization : write the ocean domain mesh askfile(s)4 !! Ocean initialization : write the ocean domain mesh file(s) 5 5 !!====================================================================== 6 6 !! History : OPA ! 1997-02 (G. Madec) Original code 7 7 !! 8.1 ! 1999-11 (M. Imbard) NetCDF FORMAT with IOIPSL 8 8 !! NEMO 1.0 ! 2002-08 (G. Madec) F90 and several file 9 !! 3.0 ! 2008-01 (S. Masson) add dom_uniq 10 !! 4.0 ! 2011-01 (A. R. Porter, STFC Daresbury) dynamical allocation 9 11 !!---------------------------------------------------------------------- 10 12 11 13 !!---------------------------------------------------------------------- 12 14 !! dom_wri : create and write mesh and mask file(s) 13 !! nmsh = 1 : mesh_mask file 14 !! = 2 : mesh and mask file 15 !! = 3 : mesh_hgr, mesh_zgr and mask 15 !! dom_uniq : 16 16 !!---------------------------------------------------------------------- 17 17 USE dom_oce ! ocean space and time domain … … 25 25 26 26 PUBLIC dom_wri ! routine called by inidom.F90 27 PUBLIC dom_wri_alloc ! routine called by nemogcm.F9028 29 LOGICAL, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: lldbl ! Used in dom_uniq to store whether each point is unique or not30 27 31 28 !! * Substitutions … … 37 34 !!---------------------------------------------------------------------- 38 35 CONTAINS 39 40 FUNCTION dom_wri_alloc()41 !!----------------------------------------------------------------------42 !! *** ROUTINE dom_wri_alloc ***43 !!----------------------------------------------------------------------44 INTEGER :: dom_wri_alloc45 !!----------------------------------------------------------------------46 47 ALLOCATE(lldbl(jpi,jpj,1), Stat = dom_wri_alloc)48 49 END FUNCTION dom_wri_alloc50 51 36 52 37 SUBROUTINE dom_wri … … 144 129 CALL iom_rstput( 0, 0, inum2, 'fmask', fmask, ktype = jp_i1 ) 145 130 146 CALL dom_uniq( zprw, 'T')131 CALL dom_uniq( zprw, 'T' ) 147 132 zprt = tmask(:,:,1) * zprw ! ! unique point mask 148 133 CALL iom_rstput( 0, 0, inum2, 'tmaskutil', zprt, ktype = jp_i1 ) 149 CALL dom_uniq( zprw, 'U')134 CALL dom_uniq( zprw, 'U' ) 150 135 zprt = umask(:,:,1) * zprw 151 136 CALL iom_rstput( 0, 0, inum2, 'umaskutil', zprt, ktype = jp_i1 ) 152 CALL dom_uniq( zprw, 'V')137 CALL dom_uniq( zprw, 'V' ) 153 138 zprt = vmask(:,:,1) * zprw 154 139 CALL iom_rstput( 0, 0, inum2, 'vmaskutil', zprt, ktype = jp_i1 ) 155 CALL dom_uniq( zprw, 'F')140 CALL dom_uniq( zprw, 'F' ) 156 141 zprt = fmask(:,:,1) * zprw 157 142 CALL iom_rstput( 0, 0, inum2, 'fmaskutil', zprt, ktype = jp_i1 ) … … 283 268 284 269 285 SUBROUTINE dom_uniq( puniq, cdgrd )270 SUBROUTINE dom_uniq( puniq, cdgrd ) 286 271 !!---------------------------------------------------------------------- 287 272 !! *** ROUTINE dom_uniq *** … … 296 281 USE wrk_nemo, ONLY: ztstref => wrk_2d_1 ! array with different values for each element 297 282 !! 298 CHARACTER(len=1) , INTENT(in ) ::cdgrd !299 REAL(wp), DIMENSION(:,:) , INTENT(inout) ::puniq !300 ! 301 REAL(wp) :: zshift! shift value link to the process number302 INTEGER :: ji! dummy loop indices303 !!----------------------------------------------------------------------304 305 IF(.not. wrk_use(2, 1))THEN 306 CALL ctl_stop('dom_uniq: ERROR - requested workspace array unavailable.')307 RETURN283 CHARACTER(len=1) , INTENT(in ) :: cdgrd ! 284 REAL(wp), DIMENSION(:,:), INTENT(inout) :: puniq ! 285 ! 286 REAL(wp) :: zshift ! shift value link to the process number 287 INTEGER :: ji ! dummy loop indices 288 LOGICAL, DIMENSION(SIZE(puniq,1),SIZE(puniq,2),1) :: lldbl ! store whether each point is unique or not 289 !!---------------------------------------------------------------------- 290 291 IF( .not. wrk_use(2, 1) ) THEN 292 CALL ctl_stop('dom_uniq: ERROR - requested workspace array unavailable.') ; RETURN 308 293 END IF 309 294 -
branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/DTA/dtasal.F90
r2590 r2618 25 25 PRIVATE 26 26 27 PUBLIC dta_sal ! called by step.F90 and inidta.F90 28 PUBLIC dta_sal_alloc ! Called by nemogcm.F90 29 30 LOGICAL , PUBLIC, PARAMETER :: lk_dtasal = .TRUE. !: salinity data flag 31 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: s_dta !: salinity data at given time-step 32 33 TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_sal ! structure of input SST (file informations, fields read) 27 PUBLIC dta_sal ! called by step.F90 and inidta.F90 28 29 LOGICAL , PUBLIC, PARAMETER :: lk_dtasal = .TRUE. !: salinity data flag 30 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: s_dta !: salinity data at given time-step 31 32 TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_sal ! structure of input SST (file informations, fields read) 34 33 35 34 !! * Substitutions 36 35 # include "domzgr_substitute.h90" 37 36 !!---------------------------------------------------------------------- 38 !! NEMO/OPA 3.3 , NEMO Consortium (2010)37 !! NEMO/OPA 4.0 , NEMO Consortium (2011) 39 38 !! $Id$ 40 39 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 41 40 !!---------------------------------------------------------------------- 42 41 CONTAINS 43 44 FUNCTION dta_sal_alloc()45 IMPLICIT none46 INTEGER :: dta_sal_alloc47 INTEGER :: ierr48 49 ALLOCATE(s_dta(jpi,jpj,jpk), &50 sf_sal(1), &51 Stat=ierr)52 IF(ierr <= 0)THEN53 ALLOCATE( sf_sal(1)%fnow(jpi,jpj,jpk) )54 END IF55 56 dta_sal_alloc = ierr57 58 END FUNCTION dta_sal_alloc59 42 60 43 SUBROUTINE dta_sal( kt ) … … 69 52 !! between two monthly values. 70 53 !!---------------------------------------------------------------------- 71 INTEGER, INTENT(in) :: kt 54 INTEGER, INTENT(in) :: kt ! ocean time step 72 55 ! 73 INTEGER :: ji, jj, jk, jl, jkk ! dummyloop indicies74 INTEGER :: ik, ierr or ! temporaryintegers56 INTEGER :: ji, jj, jk, jl, jkk ! local loop indicies 57 INTEGER :: ik, ierr0, ierr1, ierr2 ! local integers 75 58 #if defined key_tradmp 76 INTEGER :: il0, il1, ii0, ii1, ij0, ij1 ! temporaryintegers59 INTEGER :: il0, il1, ii0, ii1, ij0, ij1 ! local integers 77 60 #endif 78 61 REAL(wp):: zl … … 105 88 WRITE(numout,*) '~~~~~~~ ' 106 89 ENDIF 107 ! ARPDBG moved first two allocate's into dta_sal_alloc() 108 !!$ ALLOCATE( sf_sal(1), STAT=ierror ) 109 !!$ IF( ierror > 0 ) THEN 110 !!$ CALL ctl_stop( 'dta_sal: unable to allocate sf_sal structure' ) ; RETURN 111 !!$ ENDIF 112 !!$ ALLOCATE( sf_sal(1)%fnow(jpi,jpj,jpk) ) 113 IF( sn_sal%ln_tint ) ALLOCATE( sf_sal(1)%fdta(jpi,jpj,jpk,2) ) 90 ALLOCATE( sf_sal(1) , STAT=ierr0 ) 91 ALLOCATE( sf_sal(1)%fnow(jpi,jpj,jpk) , STAT=ierr1 ) 92 IF( sn_sal%ln_tint ) ALLOCATE( sf_sal(1)%fdta(jpi,jpj,jpk,2), STAT=ierr2 ) 93 IF( ierr0+ierr1+ierr2 > 0 ) CALL ctl_stop( 'STOP', 'dta_sal: unable to allocate sf_sal structure' ) 114 94 ! ! fill sf_sal with sn_sal and control print 115 95 CALL fld_fill( sf_sal, (/ sn_sal /), cn_dir, 'dta_sal', 'Salinity data', 'namdta_sal' ) -
branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/DTA/dtatem.F90
r2590 r2618 25 25 PRIVATE 26 26 27 PUBLIC dta_tem ! called by step.F90 and inidta.F90 28 PUBLIC dta_tem_alloc ! called by nemo_init in nemogcm.F90 29 30 LOGICAL , PUBLIC, PARAMETER :: lk_dtatem = .TRUE. !: temperature data flag 31 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: t_dta !: temperature data at given time-step 27 PUBLIC dta_tem ! called by step.F90 and inidta.F90 28 29 LOGICAL , PUBLIC, PARAMETER :: lk_dtatem = .TRUE. !: temperature data flag 30 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: t_dta !: temperature data at given time-step 32 31 33 32 TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_tem ! structure of input SST (file informations, fields read) … … 36 35 # include "domzgr_substitute.h90" 37 36 !!---------------------------------------------------------------------- 38 !! NEMO/OPA 3.3 , NEMO Consortium (2010)37 !! NEMO/OPA 4.0 , NEMO Consortium (2011) 39 38 !! $Id$ 40 39 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 41 40 !!---------------------------------------------------------------------- 42 41 CONTAINS 43 44 FUNCTION dta_tem_alloc()45 IMPLICIT none46 INTEGER :: dta_tem_alloc47 INTEGER :: ierror48 ALLOCATE(t_dta(jpi,jpj,jpk), &49 sf_tem(1), &50 STAT=ierror )51 IF( ierror <= 0 ) THEN52 ALLOCATE( sf_tem(1)%fnow(jpi,jpj,jpk), STAT=ierror )53 END IF54 55 dta_tem_alloc = ierror56 57 END FUNCTION dta_tem_alloc58 59 42 60 43 SUBROUTINE dta_tem( kt ) … … 75 58 !! ** Action : define t_dta array at time-step kt 76 59 !!---------------------------------------------------------------------- 77 INTEGER, INTENT( in ) :: kt 60 INTEGER, INTENT( in ) :: kt ! ocean time-step 78 61 ! 79 INTEGER :: ji, jj, jk, jl, jkk 80 INTEGER :: ik, ierr or ! temporaryintegers62 INTEGER :: ji, jj, jk, jl, jkk ! dummy loop indicies 63 INTEGER :: ik, ierr0, ierr1, ierr2 ! local integers 81 64 #if defined key_tradmp 82 INTEGER :: il0, il1, ii0, ii1, ij0, ij1 ! temporaryintegers65 INTEGER :: il0, il1, ii0, ii1, ij0, ij1 ! local integers 83 66 #endif 84 67 REAL(wp):: zl … … 112 95 WRITE(numout,*) '~~~~~~~ ' 113 96 ENDIF 114 ! ARPDBG - moved into dta_tem_alloc() 115 !!$ ALLOCATE( sf_tem(1), STAT=ierror ) 116 !!$ IF( ierror > 0 ) THEN 117 !!$ CALL ctl_stop( 'dta_tem: unable to allocate sf_tem structure' ) ; RETURN 118 !!$ ENDIF 119 !!$ ALLOCATE( sf_tem(1)%fnow(jpi,jpj,jpk) ) 120 IF( sn_tem%ln_tint ) ALLOCATE( sf_tem(1)%fdta(jpi,jpj,jpk,2) ) 97 ALLOCATE( sf_tem(1) , STAT=ierr0 ) 98 ALLOCATE( sf_tem(1)%fnow(jpi,jpj,jpk) , STAT=ierr1 ) 99 IF( sn_tem%ln_tint ) ALLOCATE( sf_tem(1)%fdta(jpi,jpj,jpk,2), STAT=ierr2 ) 100 IF( ierr0+ierr1+ierr2 > 0 ) CALL ctl_stop( 'STOP', 'dta_sal: unable to allocate sf_sal structure' ) 121 101 ! ! fill sf_tem with sn_tem and control print 122 102 CALL fld_fill( sf_tem, (/ sn_tem /), cn_dir, 'dta_tem', 'Temperature data', 'namdta_tem' ) -
branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/DYN/divcur.F90
r2592 r2618 35 35 PRIVATE 36 36 37 PUBLIC div_cur ! routine called by step.F90 and istate.F90 38 PUBLIC div_cur_alloc ! routine called by nemogcm.F90 39 40 ! These workspace arrays are not replaced by wrk_nemo because they 41 ! have extents greater than (jpi,jpj) 42 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zwu ! workspace 43 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zwv ! workspace 37 PUBLIC div_cur ! routine called by step.F90 and istate.F90 44 38 45 39 !! * Substitutions … … 53 47 CONTAINS 54 48 55 FUNCTION div_cur_alloc()56 !!----------------------------------------------------------------------57 !! *** ROUTINE div_cur_alloc ***58 !!----------------------------------------------------------------------59 INTEGER :: div_cur_alloc60 !!----------------------------------------------------------------------61 62 div_cur_alloc = 063 64 49 #if defined key_noslip_accurate 65 ALLOCATE(zwu( jpi, 1:jpj+2), zwv(-1:jpi+2, jpj), Stat=div_cur_alloc) 66 #endif 67 68 IF(div_cur_alloc /= 0)THEN 69 CALL ctl_warn('div_cur_alloc: failed to allocate arrays.') 70 END IF 71 72 END FUNCTION div_cur_alloc 73 74 #if defined key_noslip_accurate 75 !!---------------------------------------------------------------------- 76 !! 'key_noslip_accurate' 2nd order centered scheme 77 !! 4th order at the coast 50 !!---------------------------------------------------------------------- 51 !! 'key_noslip_accurate' 2nd order interior + 4th order at the coast 78 52 !!---------------------------------------------------------------------- 79 53 … … 83 57 !! 84 58 !! ** Purpose : compute the horizontal divergence and the relative 85 !! vorticity at before and now time-step59 !! vorticity at before and now time-step 86 60 !! 87 61 !! ** Method : I. divergence : … … 107 81 !! - update rotb , rotn , the before & now rel. vorticity 108 82 !!---------------------------------------------------------------------- 109 INTEGER, INTENT( in ) :: kt ! ocean time-step index 110 ! 111 INTEGER :: ji, jj, jk ! dummy loop indices 112 INTEGER :: ii, ij, jl ! temporary integer 113 INTEGER :: ijt, iju ! temporary integer 114 REAL(wp) :: zraur, zdep 83 INTEGER, INTENT(in) :: kt ! ocean time-step index 84 ! 85 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zwu ! specific 2D workspace 86 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zwv ! specific 2D workspace 87 ! 88 INTEGER :: ji, jj, jk, jl ! dummy loop indices 89 INTEGER :: ii, ij, ijt, iju, ierr ! local integer 90 REAL(wp) :: zraur, zdep ! local scalar 115 91 !!---------------------------------------------------------------------- 116 92 … … 119 95 IF(lwp) WRITE(numout,*) 'div_cur : horizontal velocity divergence and relative vorticity' 120 96 IF(lwp) WRITE(numout,*) '~~~~~~~ NOT optimal for auto-tasking case' 97 ! 98 ALLOCATE( zwu( jpi, 1:jpj+2) , zwv(-1:jpi+2, jpj) , Stat=ierr ) 99 IF( lk_mpp ) CALL mpp_sum( ierr ) 100 IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'div_cur : unable to allocate arrays' ) 121 101 ENDIF 122 102 -
branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/DYN/dynldf_bilapg.F90
r2590 r2618 4 4 !! Ocean dynamics: lateral viscosity trend 5 5 !!====================================================================== 6 !! History : OPA ! 1997-07 (G. Madec) Original code 7 !! NEMO 1.0 ! 2002-08 (G. Madec) F90: Free form and module 8 !! 2.0 ! 2004-08 (C. Talandier) New trends organization 9 !!---------------------------------------------------------------------- 6 10 #if defined key_ldfslp || defined key_esopa 7 11 !!---------------------------------------------------------------------- … … 12 16 !! ldfguv : 13 17 !!---------------------------------------------------------------------- 14 !! * Modules used15 18 USE oce ! ocean dynamics and tracers 16 19 USE dom_oce ! ocean space and time domain … … 27 30 PRIVATE 28 31 29 !! * Routine accessibility 30 PUBLIC dyn_ldf_bilapg ! called by step.F90 31 PUBLIC dyn_ldf_bilapg_alloc ! called by nemogcm.F90 32 33 ! These are just workspace arrays but since they're (jpi,jpk) it's not 34 ! worth putting them in the wrk_nemo module. 35 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zfuw, zfvw, zdiu, zdiv 36 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zdju, zdj1u, zdjv, zdj1v 32 PUBLIC dyn_ldf_bilapg ! called by step.F90 33 34 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zfuw, zfvw , zdiu, zdiv ! 2D workspace (ldfguv) 35 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zdju, zdj1u, zdjv, zdj1v ! 2D workspace (ldfguv) 37 36 38 37 !! * Substitutions … … 47 46 CONTAINS 48 47 49 FUNCTION dyn_ldf_bilapg_alloc()48 INTEGER FUNCTION dyn_ldf_bilapg_alloc() 50 49 !!---------------------------------------------------------------------- 51 50 !! *** ROUTINE dyn_ldf_bilapg_alloc *** 52 51 !!---------------------------------------------------------------------- 53 INTEGER :: dyn_ldf_bilapg_alloc 54 55 ALLOCATE(zfuw(jpi,jpk), zfvw(jpi,jpk), zdiu(jpi,jpk), zdiv(jpi,jpk), & 56 zdju(jpi,jpk), zdj1u(jpi,jpk), zdjv(jpi,jpk), zdj1v(jpi,jpk),& 57 Stat = dyn_ldf_bilapg_alloc) 58 59 IF(dyn_ldf_bilapg_alloc /= 0)THEN 60 CALL ctl_warn('dyn_ldf_bilapg_alloc: failed to allocate arrays') 61 END IF 62 52 ! 53 ALLOCATE( zfuw(jpi,jpk) , zfvw (jpi,jpk) , zdiu(jpi,jpk) , zdiv (jpi,jpk) , & 54 & zdju(jpi,jpk) , zdj1u(jpi,jpk) , zdjv(jpi,jpk) , zdj1v(jpi,jpk) , STAT=dyn_ldf_bilapg_alloc) 55 ! 56 IF( dyn_ldf_bilapg_alloc /= 0 ) CALL ctl_warn('dyn_ldf_bilapg_alloc: failed to allocate arrays') 57 ! 63 58 END FUNCTION dyn_ldf_bilapg_alloc 64 59 … … 90 85 !! biharmonic mixing trend. 91 86 !! - save the trend in (zwk3,zwk4) ('key_trddyn') 92 !! 93 !! History : 94 !! 8.0 ! 97-07 (G. Madec) Original code 95 !! 8.5 ! 02-08 (G. Madec) F90: Free form and module 96 !! 9.0 ! 04-08 (C. Talandier) New trends organization 97 !!---------------------------------------------------------------------- 98 !! * Modules used 99 USE oce, ONLY : zwk3 => ta, & ! use ta as 3D workspace 100 zwk4 => sa ! use sa as 3D workspace 101 USE wrk_nemo, ONLY: wrk_use, wrk_release 102 ! work array used for rotated biharmonic operator on 103 ! tracers and/or momentum 104 USE wrk_nemo, ONLY: zwk1 => wrk_3d_1, & 105 zwk2 => wrk_3d_2 106 !! * Arguments 87 !!---------------------------------------------------------------------- 88 USE wrk_nemo, ONLY: wrk_use, wrk_release 89 USE wrk_nemo, ONLY: zwk1 => wrk_3d_1 , zwk2 => wrk_3d_2 ! 3D workspace 90 USE oce , ONLY: zwk3 => ta , zwk4 => sa ! ta, sa used as 3D workspace 91 ! 107 92 INTEGER, INTENT( in ) :: kt ! ocean time-step index 108 109 !! * Local declarations 93 ! 110 94 INTEGER :: ji, jj, jk ! dummy loop indices 111 95 !!---------------------------------------------------------------------- 112 96 113 IF(.NOT. wrk_use(3, 1,2))THEN 114 CALL ctl_stop('dyn_ldf_bilapg: requested workspace arrays unavailable.') 115 RETURN 97 IF( .NOT. wrk_use(3, 1,2) ) THEN 98 CALL ctl_stop('dyn_ldf_bilapg: requested workspace arrays unavailable.') ; RETURN 116 99 END IF 117 100 … … 122 105 zwk1(:,:,:) = 0.e0 ; zwk3(:,:,:) = 0.e0 123 106 zwk2(:,:,:) = 0.e0 ; zwk4(:,:,:) = 0.e0 107 ! ! allocate dyn_ldf_bilapg arrays 108 IF( dyn_ldf_bilapg_alloc() /= 0 ) CALL ctl_stop('STOP', 'dyn_ldf_bilapg: failed to allocate arrays') 124 109 ENDIF 125 110 126 111 ! Laplacian of (ub,vb) multiplied by ahm 127 112 ! -------------------------------------- 128 ! rotated harmonic operator applied to (ub,vb) 129 ! and multiply by ahmu, ahmv (output in (zwk1,zwk2) ) 130 131 CALL ldfguv ( ub, vb, zwk1, zwk2, 1 ) 132 133 134 ! Lateral boundary conditions on (zwk1,zwk2) 135 CALL lbc_lnk( zwk1, 'U', -1. ) 136 CALL lbc_lnk( zwk2, 'V', -1. ) 137 113 CALL ldfguv( ub, vb, zwk1, zwk2, 1 ) ! rotated harmonic operator applied to (ub,vb) 114 ! ! and multiply by ahmu, ahmv (output in (zwk1,zwk2) ) 115 CALL lbc_lnk( zwk1, 'U', -1. ) ; CALL lbc_lnk( zwk2, 'V', -1. ) ! Lateral boundary conditions 138 116 139 117 ! Bilaplacian of (ub,vb) 140 118 ! ---------------------- 141 ! rotated harmonic operator applied to (zwk1,zwk2) (output in (zwk3,zwk4) ) 142 143 CALL ldfguv ( zwk1, zwk2, zwk3, zwk4, 2 ) 144 145 146 ! Update the momentum trends (j-slab : 2, jpj-1) 119 CALL ldfguv( zwk1, zwk2, zwk3, zwk4, 2 ) ! rotated harmonic operator applied to (zwk1,zwk2) 120 ! ! (output in (zwk3,zwk4) ) 121 122 ! Update the momentum trends 147 123 ! -------------------------- 148 ! ! =============== 149 DO jj = 2, jpjm1 ! Vertical slab 150 ! ! =============== 124 DO jj = 2, jpjm1 ! add the diffusive trend to the general momentum trends 151 125 DO jk = 1, jpkm1 152 126 DO ji = 2, jpim1 153 ! add the diffusive trend to the general momentum trends154 127 ua(ji,jj,jk) = ua(ji,jj,jk) + zwk3(ji,jj,jk) 155 128 va(ji,jj,jk) = va(ji,jj,jk) + zwk4(ji,jj,jk) 156 129 END DO 157 130 END DO 158 ! ! =============== 159 END DO ! End of slab 160 ! ! =============== 161 IF(.NOT. wrk_release(3, 1,2))THEN 162 CALL ctl_stop('dyn_ldf_bilapg: failed to release workspace arrays.') 163 END IF 131 END DO 132 ! 133 IF( .NOT. wrk_release(3, 1,2) ) CALL ctl_stop('dyn_ldf_bilapg: failed to release workspace arrays') 164 134 ! 165 135 END SUBROUTINE dyn_ldf_bilapg … … 206 176 !! second order vertical derivative term) 207 177 !! 'key_trddyn' defined: the trend is saved for diagnostics. 208 !!209 !! History :210 !! 8.0 ! 97-07 (G. Madec) Original code211 !! 8.5 ! 02-08 (G. Madec) F90: Free form and module212 178 !!---------------------------------------------------------------------- 213 179 USE wrk_nemo, ONLY: wrk_use, wrk_release … … 216 182 USE wrk_nemo, ONLY: zdkv => wrk_2d_7, zdk1v => wrk_2d_8 217 183 !! 218 !! * Arguments 219 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( in ) :: & 220 pu, pv ! momentum fields (before u and v for the 1st call, and 221 ! ! laplacian of these fields multiplied by ahm for the 2nd 222 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( out ) :: & 223 plu, plv ! partial harmonic operator applied to 224 ! ! pu and pv (all the components except 225 ! ! second order vertical derivative term) 226 INTEGER, INTENT( in ) :: & 227 kahm ! =1 the laplacian is multiplied by the eddy diffusivity coef. 228 ! ! =2 no multiplication 229 230 !! * Local declarations 231 INTEGER :: ji, jj, jk ! dummy loop indices 232 REAL(wp) :: & 233 zabe1, zabe2, zcof1, zcof2, & ! temporary scalars 234 zcoef0, zcoef3, zcoef4 235 REAL(wp) :: & 236 zbur, zbvr, zmkt, zmkf, zuav, zvav, & 237 zuwslpi, zuwslpj, zvwslpi, zvwslpj 238 !!---------------------------------------------------------------------- 239 240 IF(.NOT. wrk_use(2, 1,2,3,4,5,6,7,8))THEN 241 CALL ctl_stop('dyn:ldfguv : requested workspace arrays unavailable.') 242 RETURN 184 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pu , pv ! 1st call: before horizontal velocity 185 ! ! 2nd call: ahm x these fields 186 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( out) :: plu, plv ! partial harmonic operator applied to 187 ! ! pu and pv (all the components except 188 ! ! second order vertical derivative term) 189 INTEGER , INTENT(in ) :: kahm ! =1 1st call ; =2 2nd call 190 ! 191 INTEGER :: ji, jj, jk ! dummy loop indices 192 REAL(wp) :: zabe1 , zabe2 , zcof1 , zcof2 ! local scalar 193 REAL(wp) :: zcoef0, zcoef3, zcoef4 ! - - 194 REAL(wp) :: zbur, zbvr, zmkt, zmkf, zuav, zvav ! - - 195 REAL(wp) :: zuwslpi, zuwslpj, zvwslpi, zvwslpj ! - - 196 !!---------------------------------------------------------------------- 197 198 IF( .NOT. wrk_use(2, 1,2,3,4,5,6,7,8) ) THEN 199 CALL ctl_stop('dyn:ldfguv : requested workspace arrays unavailable.') ; RETURN 243 200 END IF 244 201 ! ! ********** ! ! =============== -
branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/DYN/dynldf_iso.F90
r2590 r2618 4 4 !! Ocean dynamics: lateral viscosity trend 5 5 !!====================================================================== 6 !! History : OPA ! 97-07 (G. Madec) Original code 7 !! NEMO 1.0 ! 2002-08 (G. Madec) F90: Free form and module 8 !! - ! 2004-08 (C. Talandier) New trends organization 9 !! 2.0 ! 2005-11 (G. Madec) s-coordinate: horizontal diffusion 10 !!---------------------------------------------------------------------- 6 11 #if defined key_ldfslp || defined key_esopa 7 12 !!---------------------------------------------------------------------- … … 12 17 !! tal s-coordinate laplacian operator. 13 18 !!---------------------------------------------------------------------- 14 !! * Modules used15 19 USE oce ! ocean dynamics and tracers 16 20 USE dom_oce ! ocean space and time domain … … 28 32 PRIVATE 29 33 30 !! * Routine accessibility 31 PUBLIC dyn_ldf_iso ! called by step.F90 32 PUBLIC dyn_ldf_iso_alloc ! called by nemogcm.F90 33 34 ! These are just workspace arrays but because they are (jpi,jpk) in extent 35 ! we can't use the arrays in wrk_nemo for them 36 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zfuw, zdiu, zdju, zdj1u 37 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zfvw, zdiv, zdjv, zdj1v 34 PUBLIC dyn_ldf_iso ! called by step.F90 35 PUBLIC dyn_ldf_iso_alloc ! called by nemogcm.F90 36 37 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zfuw, zdiu, zdju, zdj1u ! 2D workspace (dyn_ldf_iso) 38 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zfvw, zdiv, zdjv, zdj1v ! - - 38 39 39 40 !! * Substitutions … … 42 43 # include "vectopt_loop_substitute.h90" 43 44 !!---------------------------------------------------------------------- 44 !! NEMO/OPA 3.3 , NEMO Consortium (201 0)45 !! NEMO/OPA 3.3 , NEMO Consortium (2011) 45 46 !! $Id$ 46 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 47 !!---------------------------------------------------------------------- 48 47 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 48 !!---------------------------------------------------------------------- 49 49 CONTAINS 50 50 51 FUNCTION dyn_ldf_iso_alloc()51 INTEGER FUNCTION dyn_ldf_iso_alloc() 52 52 !!---------------------------------------------------------------------- 53 53 !! *** ROUTINE dyn_ldf_iso_alloc *** 54 54 !!---------------------------------------------------------------------- 55 INTEGER :: dyn_ldf_iso_alloc 56 !!---------------------------------------------------------------------- 57 58 ALLOCATE(zfuw(jpi,jpk), zdiu(jpi,jpk), zdju(jpi,jpk), zdj1u(jpi,jpk), & 59 zfvw(jpi,jpk), zdiv(jpi,jpk), zdjv(jpi,jpk), zdj1v(jpi,jpk), & 60 Stat=dyn_ldf_iso_alloc) 61 62 IF(dyn_ldf_iso_alloc /= 0)THEN 63 CALL ctl_warn('dyn_ldf_iso_alloc: array allocate failed.') 64 END IF 65 55 ! 56 ALLOCATE( zfuw(jpi,jpk) , zdiu(jpi,jpk) , zdju(jpi,jpk) , zdj1u(jpi,jpk) , & 57 & zfvw(jpi,jpk) , zdiv(jpi,jpk) , zdjv(jpi,jpk) , zdj1v(jpi,jpk) , STAT=dyn_ldf_iso_alloc) 58 ! 59 IF( dyn_ldf_iso_alloc /= 0 ) CALL ctl_warn('dyn_ldf_iso_alloc: array allocate failed.') 60 ! 66 61 END FUNCTION dyn_ldf_iso_alloc 67 62 … … 110 105 !! Update (avmu,avmv) to accompt for the diagonal vertical component 111 106 !! of the rotated operator in dynzdf module 112 !!113 !! History :114 !! 8.0 ! 97-07 (G. Madec) Original code115 !! 8.5 ! 02-08 (G. Madec) F90: Free form and module116 !! 9.0 ! 04-08 (C. Talandier) New trends organization117 !! ! 05-11 (G. Madec) s-coordinate: horizontal diffusion118 107 !!---------------------------------------------------------------------- 119 USE wrk_nemo, ONLY: wrk_use, wrk_release 120 USE wrk_nemo, ONLY: ziut => wrk_2d_1, zjuf => wrk_2d_2, & ! temporary workspace 121 zjvt => wrk_2d_3, zivf => wrk_2d_4, & 122 zdku => wrk_2d_5, zdk1u => wrk_2d_6, & 123 zdkv => wrk_2d_7, zdk1v => wrk_2d_8 124 !! 125 !! * Arguments 126 INTEGER, INTENT( in ) :: kt ! ocean time-step index 127 128 !! * Local declarations 129 INTEGER :: ji, jj, jk ! dummy loop indices 130 REAL(wp) :: & 131 zabe1, zabe2, zcof1, zcof2, & ! temporary scalars 132 zmskt, zmskf, zbu, zbv, & 133 zuah, zvah 134 135 REAL(wp) :: & 136 zcoef0, zcoef3, zcoef4, zmkt, zmkf, & 137 zuav, zvav, zuwslpi, zuwslpj, zvwslpi, zvwslpj 138 108 USE wrk_nemo, ONLY: wrk_use, wrk_release 109 USE wrk_nemo, ONLY: ziut => wrk_2d_1 , zjuf => wrk_2d_2 , zjvt => wrk_2d_3 ! 2D workspace 110 USE wrk_nemo, ONLY: zivf => wrk_2d_4 , zdku => wrk_2d_5 , zdkv => wrk_2d_6 ! 2D workspace 111 USE wrk_nemo, ONLY: zdk1u => wrk_2d_7 , zdk1v => wrk_2d_8 112 ! 113 INTEGER, INTENT( in ) :: kt ! ocean time-step index 114 ! 115 INTEGER :: ji, jj, jk ! dummy loop indices 116 REAL(wp) :: zabe1, zabe2, zcof1, zcof2 ! local scalars 117 REAL(wp) :: zmskt, zmskf, zbu, zbv, zuah, zvah ! - - 118 REAL(wp) :: zcoef0, zcoef3, zcoef4, zmkt, zmkf ! - - 119 REAL(wp) :: zuav, zvav, zuwslpi, zuwslpj, zvwslpi, zvwslpj ! - - 139 120 !!---------------------------------------------------------------------- 140 121 141 IF( .NOT. wrk_use(2, 1,2,3,4,5,6,7,8))THEN 142 CALL ctl_stop('dyn_ldf_iso: requested workspace arrays unavailable.') 143 RETURN 122 IF( .NOT. wrk_use(2, 1,2,3,4,5,6,7,8) ) THEN 123 CALL ctl_stop('dyn_ldf_iso: requested workspace arrays unavailable.') ; RETURN 144 124 END IF 145 125 … … 148 128 IF(lwp) WRITE(numout,*) 'dyn_ldf_iso : iso-neutral laplacian diffusive operator or ' 149 129 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ s-coordinate horizontal diffusive operator' 130 ! ! allocate dyn_ldf_bilap arrays 131 IF( dyn_ldf_iso_alloc() /= 0 ) CALL ctl_stop('STOP', 'dyn_ldf_iso: failed to allocate arrays') 150 132 ENDIF 151 133 152 !! s-coordinate: Iso-level diffusion on momentum but not on tracer134 ! s-coordinate: Iso-level diffusion on momentum but not on tracer 153 135 IF( ln_dynldf_hor .AND. ln_traldf_iso ) THEN 154 155 ! set the slopes of iso-level 156 DO jk = 1, jpk 136 ! 137 DO jk = 1, jpk ! set the slopes of iso-level 157 138 DO jj = 2, jpjm1 158 139 DO ji = fs_2, fs_jpim1 ! vector opt. … … 164 145 END DO 165 146 END DO 166 167 147 ! Lateral boundary conditions on the slopes 168 148 CALL lbc_lnk( uslp , 'U', -1. ) ; CALL lbc_lnk( vslp , 'V', -1. ) … … 170 150 171 151 !!bug 172 if( kt == nit000 ) then173 IF(lwp) WRITE(numout,*) ' max slop: u', SQRT( MAXVAL(uslp*uslp)), ' v ', SQRT(MAXVAL(vslp)), &174 & ' wi', sqrt(MAXVAL(wslpi)) , ' wj', sqrt(MAXVAL(wslpj))152 IF( kt == nit000 ) then 153 IF(lwp) WRITE(numout,*) ' max slop: u', SQRT( MAXVAL(uslp*uslp)), ' v ', SQRT(MAXVAL(vslp)), & 154 & ' wi', sqrt(MAXVAL(wslpi)) , ' wj', sqrt(MAXVAL(wslpj)) 175 155 endif 176 156 !!end -
branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg.F90
r2590 r2618 91 91 !!gm they return the after velocity, not the trends (as in trazdf_imp...) 92 92 !!gm In this case, change/simplify dynnxt 93 94 93 95 94 … … 181 180 ENDIF 182 181 182 ! ! allocate dyn_spg arrays 183 IF( lk_dynspg_ts .AND. dyn_spg_ts_alloc () /= 0 ) CALL ctl_stop('STOP', 'dyn_spg_init: failed to allocate ts arrays') 184 183 185 ! ! Control of surface pressure gradient scheme options 184 186 ioptio = 0 -
branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_exp.F90
r2528 r2618 42 42 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 43 43 !!---------------------------------------------------------------------- 44 45 44 CONTAINS 46 45 -
branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_flt.F90
r2528 r2618 65 65 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 66 66 !!---------------------------------------------------------------------- 67 68 67 CONTAINS 69 68 -
branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_oce.F90
r2590 r2618 5 5 !! Ocean dynamics: Define in memory surface pressure gradient variables 6 6 !!====================================================================== 7 !! History : 1.0 ! 7 !! History : 1.0 ! 2005-12 (C. Talandier, G. Madec) Original code 8 8 !! 3.2 ! 2009-07 (R. Benshila) Suppression of rigid-lid option 9 9 !!---------------------------------------------------------------------- … … 30 30 #endif 31 31 32 !!gm BUG : always required in _ts, only some of them in vvl33 ! #if defined key_dynspg_ts || defined key_esopa34 !!gm end35 #if defined key_dynspg_ts || defined key_vvl || defined key_esopa36 ! !!! Time splitting scheme (sub-time step variables)37 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ua_e , va_e ! barotropic velocities (after)38 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sshn_e, ssha_e, sshn_b ! sea surface heigth (now, after, average)39 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hu_e , hv_e ! now ocean depth ( = Ho+sshn_e )40 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hur_e , hvr_e ! inverse of the now depth ( = 1/(Ho+sshn_e) )41 #endif42 43 32 !!---------------------------------------------------------------------- 44 !! NEMO/OPA 3.2 , LODYC-IPSL (2009)33 !! NEMO/OPA 4.0 , LODYC-IPSL (2011) 45 34 !! $Id$ 46 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)35 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 47 36 !!====================================================================== 48 CONTAINS49 50 FUNCTION dynspg_oce_alloc()51 IMPLICIT none52 INTEGER :: dynspg_oce_alloc53 54 dynspg_oce_alloc = 055 56 #if defined key_dynspg_ts || defined key_vvl || defined key_esopa57 ALLOCATE(ua_e(jpi,jpj), va_e(jpi,jpj) , &58 sshn_e(jpi,jpj), ssha_e(jpi,jpj), sshn_b(jpi,jpj), &59 hu_e(jpi,jpj), hv_e(jpi,jpj) , &60 hur_e(jpi,jpj), hvr_e(jpi,jpj) , &61 Stat=dynspg_oce_alloc)62 #endif63 64 END FUNCTION dynspg_oce_alloc65 66 37 END MODULE dynspg_oce -
branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_ts.F90
r2613 r2618 38 38 USE prtctl ! Print control 39 39 USE in_out_manager ! I/O manager 40 USE iom 40 USE iom ! IOM library 41 41 USE restart ! only for lrst_oce 42 42 USE zdf_oce … … 53 53 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ftsw, ftse ! (only used with een vorticity scheme) 54 54 55 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: un_b, vn_b ! now averaged velocity 56 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ub_b, vb_b ! before averaged velocity 57 55 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: un_b, vn_b ! now averaged velocity 56 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ub_b, vb_b ! before averaged velocity 57 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ua_e , va_e ! barotropic velocities (after) 58 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sshn_e, ssha_e ! sea surface heigth (now, after, average) 59 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hu_e , hv_e ! now ocean depth ( = Ho+sshn_e ) 60 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hur_e , hvr_e ! inverse of the now depth ( = 1/(Ho+sshn_e) ) 58 61 59 62 !! * Substitutions 60 63 # include "domzgr_substitute.h90" 61 64 # include "vectopt_loop_substitute.h90" 62 !!---------------------------------------------------------------------- ---63 !! NEMO/OPA 3.3 , NEMO Consortium (2010)65 !!---------------------------------------------------------------------- 66 !! NEMO/OPA 4.0 , NEMO Consortium (2011) 64 67 !! $Id$ 65 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 66 !!------------------------------------------------------------------------- 67 68 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 69 !!---------------------------------------------------------------------- 68 70 CONTAINS 69 71 70 FUNCTION dyn_spg_ts_alloc()72 INTEGER FUNCTION dyn_spg_ts_alloc() 71 73 !!---------------------------------------------------------------------- 72 74 !! *** routine dyn_spg_ts_alloc *** 73 75 !!---------------------------------------------------------------------- 74 INTEGER :: dyn_spg_ts_alloc ! return value75 !!----------------------------------------------------------------------76 !77 ALLOCATE(ftnw(jpi,jpj), ftne(jpi,jpj), ftsw(jpi,jpj), ftse(jpi,jpj),&78 & un_b(jpi,jpj), vn_b(jpi,jpj), ub_b(jpi,jpj), vb_b(jpi,jpj), &79 & STAT=dyn_spg_ts_alloc)80 76 ! 77 ALLOCATE( ftnw (jpi,jpj) , ftne (jpi,jpj) , ftsw (jpi,jpj) , ftse (jpi,jpj) , & 78 & un_b (jpi,jpj) , vn_b (jpi,jpj) , ub_b (jpi,jpj) , vb_b (jpi,jpj) , ua_e (jpi,jpj) , va_e (jpi,jpj) , & 79 & sshn_e(jpi,jpj) , ssha_e(jpi,jpj) , sshn_b(jpi,jpj) , & 80 & hu_e (jpi,jpj) , hv_e (jpi,jpj) , hur_e (jpi,jpj) , hvr_e(jpi,jpj) , STAT=dyn_spg_ts_alloc ) 81 IF(lk_mpp) CALL mpp_sum( dyn_spg_ts_alloc ) 82 ! 81 83 END FUNCTION dyn_spg_ts_alloc 82 84 … … 122 124 !! 123 125 INTEGER :: ji, jj, jk, jn ! dummy loop indices 124 INTEGER :: icycle ! temporary scalar 125 126 REAL(wp) :: zraur, zcoef, z2dt_e, z2dt_b ! temporary scalars 127 REAL(wp) :: z1_8, zx1, zy1 ! - - 128 REAL(wp) :: z1_4, zx2, zy2 ! - - 129 REAL(wp) :: zu_spg, zu_cor, zu_sld, zu_asp ! - - 130 REAL(wp) :: zv_spg, zv_cor, zv_sld, zv_asp ! - - 126 INTEGER :: icycle ! local scalar 127 REAL(wp) :: zraur, zcoef, z2dt_e, z2dt_b ! local scalars 128 REAL(wp) :: z1_8, zx1, zy1 ! - - 129 REAL(wp) :: z1_4, zx2, zy2 ! - - 130 REAL(wp) :: zu_spg, zu_cor, zu_sld, zu_asp ! - - 131 REAL(wp) :: zv_spg, zv_cor, zv_sld, zv_asp ! - - 131 132 !!---------------------------------------------------------------------- 132 133 133 134 IF(.NOT. wrk_use(2, 1, 2, 3, 4, 5, 6, 7, 8, 9,10, & 134 11,12,13,14,15,16,17,18,19,20,21))THEN 135 CALL ctl_stop('dyn_spg_ts: requested workspace arrays unavailable.') 136 RETURN 135 11,12,13,14,15,16,17,18,19,20,21 ) ) THEN 136 CALL ctl_stop( 'dyn_spg_ts: requested workspace arrays unavailable.' ) ; RETURN 137 137 END IF 138 138 … … 143 143 IF(lwp) WRITE(numout,*) '~~~~~~~~~~ free surface with time splitting' 144 144 IF(lwp) WRITE(numout,*) ' Number of sub cycle in 1 time-step (2 rdt) : icycle = ', 2*nn_baro 145 ! 146 ! ! allocate dyn_spg_ts arrays 147 IF( dyn_spg_ts_alloc() /= 0 ) CALL ctl_stop('STOP', 'dyn_spg_ts_alloc: failed to allocate arrays') 145 148 ! 146 149 CALL ts_rst( nit000, 'READ' ) ! read or initialize the following fields: un_b, vn_b … … 484 487 ! ! - Correct the velocity 485 488 486 IF( lk_obc ) CALL obc_fla_ts 489 IF( lk_obc ) CALL obc_fla_ts ( ua_e, va_e, sshn_e, ssha_e ) 487 490 IF( lk_bdy .OR. ln_tides ) CALL bdy_dyn_fla( sshn_e ) 488 491 ! -
branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/DYN/dynvor.F90
r2590 r2618 39 39 PUBLIC dyn_vor ! routine called by step.F90 40 40 PUBLIC dyn_vor_init ! routine called by opa.F90 41 PUBLIC dyn_vor_alloc ! routine called by nemogcm.F9042 41 43 42 ! !!* Namelist namdyn_vor: vorticity term … … 51 50 INTEGER :: nrvm = 2 ! =2 relative vorticity ; =3 metric term 52 51 INTEGER :: ntot = 4 ! =4 total vorticity (relative + planetary) ; =5 coriolis + metric term 53 54 !!$#if defined key_vvl55 !!$ REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3f56 !!$#else57 !!$ REAL(wp), ALLOCATABLE, DIMENSION(jpi,jpj,jpk), SAVE :: ze3f58 !!$#endif59 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ze3f60 52 61 53 !! * Substitutions … … 67 59 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 68 60 !!---------------------------------------------------------------------- 69 70 61 CONTAINS 71 72 FUNCTION dyn_vor_alloc()73 !!----------------------------------------------------------------------74 !! *** Routine dyn_vor_alloc ***75 !!----------------------------------------------------------------------76 IMPLICIT none77 INTEGER :: dyn_vor_alloc78 !!----------------------------------------------------------------------79 80 ALLOCATE(ze3f(jpi,jpj,jpk), Stat=dyn_vor_alloc)81 82 IF(dyn_vor_alloc /= 0 )THEN83 CALL ctl_warn('dyn_vor_alloc: failed to allocate array ze3f.')84 END IF85 86 END FUNCTION dyn_vor_alloc87 88 62 89 63 SUBROUTINE dyn_vor( kt ) … … 584 558 !! References : Arakawa and Lamb 1980, Mon. Wea. Rev., 109, 18-36 585 559 !!---------------------------------------------------------------------- 586 USE wrk_nemo, ONLY: wrk_use, wrk_release 587 USE wrk_nemo, ONLY: zwx => wrk_2d_1, zwy => wrk_2d_2, zwz => wrk_2d_3 588 USE wrk_nemo, ONLY: ztnw => wrk_2d_4, ztne => wrk_2d_5, & 589 ztsw => wrk_2d_6, ztse => wrk_2d_7 590 !! 560 USE wrk_nemo, ONLY: wrk_use, wrk_release 561 USE wrk_nemo, ONLY: zwx => wrk_2d_1 , zwy => wrk_2d_2 , zwz => wrk_2d_3 562 USE wrk_nemo, ONLY: ztnw => wrk_2d_4 , ztne => wrk_2d_5 563 USE wrk_nemo, ONLY: ztsw => wrk_2d_6 , ztse => wrk_2d_7 564 #if defined key_vvl 565 USE wrk_nemo, ONLY: ze3f => wrk_3d_1 566 #endif 567 ! 591 568 INTEGER , INTENT(in ) :: kt ! ocean time-step index 592 569 INTEGER , INTENT(in ) :: kvor ! =ncor (planetary) ; =ntot (total) ; … … 596 573 !! 597 574 INTEGER :: ji, jj, jk ! dummy loop indices 598 REAL(wp) :: zfac12, zua, zva ! temporary scalars 599 !!---------------------------------------------------------------------- 600 601 IF(.NOT. wrk_use(2, 1,2,3,4,5,6,7))THEN 602 CALL ctl_stop('dyn:vor_een : requested workspace arrays unavailable.') 603 RETURN 575 INTEGER :: ierr ! local integer 576 REAL(wp) :: zfac12, zua, zva ! local scalars 577 #if ! defined key_vvl 578 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), SAVE :: ze3f 579 #endif 580 !!---------------------------------------------------------------------- 581 582 IF(.NOT. wrk_use(2, 1,2,3,4,5,6,7) .AND. .NOT. wrk_use(3, 1) ) THEN 583 CALL ctl_stop('dyn:vor_een : requested workspace arrays unavailable.') ; RETURN 604 584 END IF 605 585 … … 608 588 IF(lwp) WRITE(numout,*) 'dyn:vor_een : vorticity term: energy and enstrophy conserving scheme' 609 589 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 590 IF( .NOT.lk_vvl ) THEN 591 ALLOCATE( ze3f(jpi,jpj,jpk) , STAT=ierr ) 592 IF( lk_mpp ) CALL mpp_sum ( ierr ) 593 IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'dyn:vor_een : unable to allocate arrays' ) 594 ENDIF 610 595 ENDIF 611 596 … … 696 681 END DO ! End of slab 697 682 ! ! =============== 698 IF(.NOT. wrk_release(2, 1,2,3,4,5,6,7))THEN 699 CALL ctl_stop('dyn:vor_een : failed to release workspace arrays.') 700 END IF 683 IF(.NOT. wrk_release(2, 1,2,3,4,5,6,7) .AND. & 684 .NOT. wrk_release(3, 1) ) CALL ctl_stop('dyn:vor_een : failed to release workspace arrays') 701 685 ! 702 686 END SUBROUTINE vor_een -
branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/FLO/flo_oce.F90
r2613 r2618 12 12 !!---------------------------------------------------------------------- 13 13 USE par_oce ! ocean parameters 14 USE in_out_manager ! I/O manager 15 USE lib_mpp ! MPP library 14 16 15 17 IMPLICIT NONE 16 18 PUBLIC 17 19 18 PUBLIC flo_oce_alloc ! Routine called in nemogcm.F9020 PUBLIC flo_oce_alloc ! Routine called in floats.F90 19 21 20 22 LOGICAL, PUBLIC, PARAMETER :: lk_floats = .TRUE. !: float flag … … 44 46 45 47 !!---------------------------------------------------------------------- 48 !! NEMO/OPA 4.0 , NEMO Consortium (2011) 49 !! $Id$ 50 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 51 !!---------------------------------------------------------------------- 46 52 CONTAINS 47 53 48 FUNCTION flo_oce_alloc()54 INTEGER FUNCTION flo_oce_alloc() 49 55 !!---------------------------------------------------------------------- 50 INTEGER :: flo_oce_alloc56 !! *** FUNCTION flo_oce_alloc *** 51 57 !!---------------------------------------------------------------------- 58 ALLOCATE( wb(jpi,jpj,jpk), Stat=flo_oce_alloc ) 52 59 ! 53 ALLOCATE(wb(jpi,jpj,jpk), Stat=flo_oce_alloc)54 !60 IF( lk_mpp ) CALL mpp_sum ( flo_oce_alloc ) 61 IF( flo_oce_alloc /= 0 ) CALL ctl_warn('flo_oce_alloc: failed to allocate arrays.') 55 62 END FUNCTION flo_oce_alloc 56 63 … … 62 69 #endif 63 70 64 !!----------------------------------------------------------------------65 !! NEMO/OPA 3.3 , NEMO Consortium (2010)66 !! $Id$67 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)68 71 !!====================================================================== 69 72 END MODULE flo_oce -
branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/FLO/floats.F90
r2528 r2618 50 50 !!---------------------------------------------------------------------- 51 51 ! 52 IF( kt == nit000 ) THEN53 IF(lwp) WRITE(numout,*)54 IF(lwp) WRITE(numout,*) 'flo_stp : call floats routine '55 IF(lwp) WRITE(numout,*) '~~~~~~~'56 57 CALL flo_dom ! compute/read initial position of floats58 59 wb(:,:,:) = wn(:,:,:) ! set wb for computation of floats trajectories at the first time step60 ENDIF61 !62 52 IF( ln_flork4 ) THEN ; CALL flo_4rk( kt ) ! Trajectories using a 4th order Runge Kutta scheme 63 53 ELSE ; CALL flo_blk( kt ) ! Trajectories using Blanke' algorithme … … 83 73 !!--------------------------------------------------------------------- 84 74 ! 75 IF(lwp) WRITE(numout,*) 76 IF(lwp) WRITE(numout,*) 'flo_stp : call floats routine ' 77 IF(lwp) WRITE(numout,*) '~~~~~~~' 78 85 79 REWIND( numnam ) ! Namelist namflo : floats 86 80 READ ( numnam, namflo ) … … 95 89 WRITE(numout,*) ' Computation of T trajectories ln_flork4 = ', ln_flork4 96 90 ENDIF 91 ! 92 ! ! allocate floats arrays 93 IF( flo_oce_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'flo_init : unable to allocate arrays' ) 94 ! 95 ! ! allocate flowri arrays 96 IF( flo_wri_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'flo_wri : unable to allocate arrays' ) 97 ! 98 CALL flo_dom ! compute/read initial position of floats 99 100 wb(:,:,:) = wn(:,:,:) ! set wb for computation of floats trajectories at the first time step 97 101 ! 98 102 END SUBROUTINE flo_init -
branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/FLO/floblk.F90
r2528 r2618 14 14 USE dom_oce ! ocean space and time domain 15 15 USE phycst ! physical constants 16 USE obc_par ! open boundary condition parameters 16 17 USE in_out_manager ! I/O manager 17 18 USE lib_mpp ! distribued memory computing library -
branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/FLO/flowri.F90
r2613 r2618 23 23 PRIVATE 24 24 25 PUBLIC flo_wri 26 PUBLIC flo_wri_alloc ! routine called by nemogcm.F9025 PUBLIC flo_wri ! routine called by floats.F90 26 PUBLIC flo_wri_alloc ! routine called by floats.F90 27 27 28 28 INTEGER :: jfl ! number of floats … … 43 43 CONTAINS 44 44 45 FUNCTION flo_wri_alloc45 INTEGER FUNCTION flo_wri_alloc 46 46 !!------------------------------------------------------------------- 47 !! *** ROUTINEflo_wri_alloc ***47 !! *** FUNCTION flo_wri_alloc *** 48 48 !!------------------------------------------------------------------- 49 INTEGER :: flo_wri_alloc 50 !!------------------------------------------------------------------- 51 ! 52 ALLOCATE(ztemp(jpk,jpnfl), zsal(jpk,jpnfl), Stat=flo_wri_alloc) 49 ALLOCATE( ztemp(jpk,jpnfl) , zsal(jpk,jpnfl) , STAT=flo_wri_alloc) 53 50 ! 54 51 IF( lk_mpp ) CALL mpp_sum ( flo_wri_alloc ) 55 52 IF( flo_wri_alloc /= 0 ) CALL ctl_warn('flo_wri_alloc: failed to allocate arrays.') 56 !57 53 END FUNCTION flo_wri_alloc 58 54 … … 75 71 INTEGER :: ic, jc , jpn 76 72 INTEGER, DIMENSION ( jpnij ) :: iproc 77 REAL(wp) :: zafl, zbfl,zcfl,zdtj73 REAL(wp) :: zafl, zbfl, zcfl, zdtj 78 74 REAL(wp) :: zxxu, zxxu_01,zxxu_10, zxxu_11 79 75 !!--------------------------------------------------------------------- 80 76 81 IF( kt == nit000 .OR. MOD( kt,nn_writefl) == 0 ) THEN77 IF( kt == nit000 .OR. MOD( kt,nn_writefl) == 0 ) THEN 82 78 83 79 ! header of output floats file -
branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/LDF/ldfdyn_oce.F90
r2590 r2618 6 6 !! History : 1.0 ! 2002-11 (G. Madec) F90: Free form and module 7 7 !!---------------------------------------------------------------------- 8 USE par_oce ! ocean parameters 8 USE par_oce ! ocean parameters 9 USE in_out_manager ! I/O manager 9 10 10 11 IMPLICIT NONE … … 20 21 REAL(wp), PUBLIC :: rn_ahmb_0 = 0._wp !: lateral laplacian background eddy viscosity (m2/s) 21 22 REAL(wp), PUBLIC :: rn_ahm_0_blp = 0._wp !: lateral bilaplacian eddy viscosity (m4/s) 22 REAL(wp), PUBLIC :: ahm0, ahmb0, ahm0_blp ! OLD namelist names23 REAL(wp), PUBLIC :: ahm0, ahmb0, ahm0_blp !: OLD namelist names 23 24 25 ! !!! eddy coeff. at U-,V-,W-pts [m2/s] 24 26 #if defined key_dynldf_c3d 25 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ahm1, ahm2, ahm3, ahm4 !** 3D coefficients **27 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ahm1, ahm2, ahm3, ahm4 !: ** 3D coefficients ** 26 28 #elif defined key_dynldf_c2d 27 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ahm1, ahm2, ahm3, ahm4 !** 2D coefficients **29 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ahm1, ahm2, ahm3, ahm4 !: ** 2D coefficients ** 28 30 #elif defined key_dynldf_c1d 29 REAL(wp), PUBLIC, DIMENSION(jpk) :: ahm1, ahm2, ahm3, ahm4 !** 2D coefficients **31 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ahm1, ahm2, ahm3, ahm4 !: ** 2D coefficients ** 30 32 #else 31 REAL(wp), PUBLIC :: ahm1, ahm2, ahm3, ahm4 !** 0D coefficients **33 REAL(wp), PUBLIC :: ahm1, ahm2, ahm3, ahm4 !: ** 0D coefficients ** 32 34 #endif 33 35 34 36 !!---------------------------------------------------------------------- 35 !! NEMO/OPA 3.3 , NEMO Consortium (2010)37 !! NEMO/OPA 4.0 , NEMO Consortium (2011) 36 38 !! $Id$ 37 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)38 !! ======================================================================39 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 40 !!---------------------------------------------------------------------- 39 41 CONTAINS 40 42 41 FUNCTION ldfdyn_oce_alloc() 42 !!---------------------------------------------------------------------- 43 !!---------------------------------------------------------------------- 44 IMPLICIT none 45 INTEGER :: ldfdyn_oce_alloc 43 INTEGER FUNCTION ldfdyn_oce_alloc() 44 !!---------------------------------------------------------------------- 45 !! *** FUNCTION ldfdyn_oce_alloc *** 46 !!---------------------------------------------------------------------- 47 #if defined key_dynldf_c3d 48 ALLOCATE( ahm1(jpi,jpj,jpk) , ahm2(jpi,jpj,jpk) , ahm3(jpi,jpj,jpk) , ahm4(jpi,jpj,jpk) , STAT=ldfdyn_oce_alloc ) 49 #elif defined key_dynldf_c2d 50 ALLOCATE( ahm1(jpi,jpj ) , ahm2(jpi,jpj ) , ahm3(jpi,jpj ) , ahm4(jpi,jpj ) , STAT=ldfdyn_oce_alloc ) 51 #elif defined key_dynldf_c1d 52 ALLOCATE( ahm1( jpk) , ahm2( jpk) , ahm3( jpk) , ahm4( jpk) , STAT=ldfdyn_oce_alloc ) 53 #endif 54 IF( ldfdyn_oce_alloc /= 0 ) CALL ctl_warn('ldfdyn_oce_alloc: failed to allocate arrays') 55 ! 56 END FUNCTION ldfdyn_oce_alloc 46 57 47 ldfdyn_oce_alloc = 0 48 49 #if defined key_dynldf_c3d 50 ALLOCATE(ahm1(jpi,jpj,jpk), ahm2(jpi,jpj,jpk), ahm3(jpi,jpj,jpk), & 51 ahm4(jpi,jpj,jpk), Stat=ldfdyn_oce_alloc) 52 #elif defined key_dynldf_c2d 53 ALLOCATE(ahm1(jpi,jpj), ahm2(jpi,jpj), ahm3(jpi,jpj), & 54 ahm4(jpi,jpj), Stat=ldfdyn_oce_alloc) 55 #elif defined key_dynldf_c1d 56 ALLOCATE(ahm1(jpk), ahm2(jpk), ahm3(jpk), & 57 ahm4(jpk), Stat=ldfdyn_oce_alloc) 58 #endif 59 60 END FUNCTION ldfdyn_oce_alloc 61 62 !!---------------------------------------------------------------------- 63 58 !!====================================================================== 64 59 END MODULE ldfdyn_oce -
branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/LDF/ldfslp.F90
r2611 r2618 38 38 PUBLIC ldf_slp_grif ! routine called by step.F90 39 39 PUBLIC ldf_slp_init ! routine called by opa.F90 40 PUBLIC ldf_slp_alloc ! routine called by nemo_init->nemo_alloc41 40 42 41 LOGICAL , PUBLIC, PARAMETER :: lk_ldfslp = .TRUE. !: slopes flag … … 61 60 ! arrays from the wrk_nemo module with a bit of code re-writing. The 4D workspace 62 61 ! arrays can't be used here because of the zero-indexing of some of the ranks. ARPDBG. 63 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: zdzrho , zdyrho, zdxrho ! Horizontal and vertical density gradients64 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: zti_mlb, ztj_mlb 62 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: zdzrho , zdyrho, zdxrho ! Horizontal and vertical density gradients 63 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: zti_mlb, ztj_mlb ! for Griffies operator only 65 64 66 65 !! * Substitutions … … 70 69 # include "vectopt_loop_substitute.h90" 71 70 !!---------------------------------------------------------------------- 72 !! NEMO/OPA 3.3 , NEMO Consortium (2010)71 !! NEMO/OPA 4.0 , NEMO Consortium (2011) 73 72 !! $Id$ 74 73 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 76 75 CONTAINS 77 76 78 FUNCTION ldf_slp_alloc() 79 !!---------------------------------------------------------------------- 80 !! *** ROUTINE ldf_slp_alloc *** 81 !!---------------------------------------------------------------------- 82 INTEGER :: ldf_slp_alloc 83 !!---------------------------------------------------------------------- 84 ! 85 ALLOCATE(zdzrho(jpi,jpj,jpk,0:1), zdyrho(jpi,jpj,jpk,0:1), & 86 zdxrho(jpi,jpj,jpk,0:1), zti_mlb(jpi,jpj,0:1,0:1), & 87 ztj_mlb(jpi,jpj,0:1,0:1), Stat=ldf_slp_alloc) 88 89 IF(ldf_slp_alloc /= 0)THEN 90 CALL ctl_warn('ldf_slp_alloc : failed to allocate arrays.') 91 END IF 92 77 INTEGER FUNCTION ldf_slp_alloc() 78 !!---------------------------------------------------------------------- 79 !! *** FUNCTION ldf_slp_alloc *** 80 !!---------------------------------------------------------------------- 81 ! 82 ALLOCATE( zdxrho (jpi,jpj,jpk,0:1) , zti_mlb(jpi,jpj,0:1,0:1) , & 83 & zdyrho (jpi,jpj,jpk,0:1) , ztj_mlb(jpi,jpj,0:1,0:1) , & 84 & zdzrho (jpi,jpj,jpk,0:1) , STAT=ldf_slp_alloc ) 85 ! 86 IF( lk_mpp ) CALL mpp_sum ( ldf_slp_alloc ) 87 IF( ldf_slp_alloc /= 0 ) CALL ctl_warn('ldf_slp_alloc : failed to allocate arrays.') 88 ! 93 89 END FUNCTION ldf_slp_alloc 94 90 … … 139 135 !!---------------------------------------------------------------------- 140 136 141 IF(.not. wrk_use(3, 1))THEN 142 CALL ctl_stop('ldf_slp: ERROR: requested workspace arrays are unavailable.') 143 RETURN 137 IF(.NOT. wrk_use(3, 1) ) THEN 138 CALL ctl_stop('ldf_slp: requested workspace arrays are unavailable') ; RETURN 144 139 END IF 145 140 … … 429 424 430 425 IF( (.not. wrk_use(3, 2,3,4,5)) .OR. (.not. wrk_use(2, 1)) )THEN 431 CALL ctl_stop('ldf_slp_grif: ERROR: requested workspace arrays are unavailable.') 432 RETURN 426 CALL ctl_stop('ldf_slp_grif: ERROR: requested workspace arrays are unavailable.') ; RETURN 433 427 END IF 434 428 … … 613 607 CALL lbc_lnk( wslp2, 'W', 1. ) ! lateral boundary confition on wslp2 only ==>>> gm : necessary ? to be checked 614 608 ! 615 IF( (.not. wrk_release(3, 2,3,4,5)) .OR. (.not. wrk_release(2, 1)) )THEN 616 CALL ctl_stop('ldf_slp_grif: ERROR: failed to release workspace arrays.') 617 END IF 609 IF(.NOT. wrk_release(3, 2,3,4,5) .OR. & 610 .NOT. wrk_release(2, 1) ) CALL ctl_stop('ldf_slp_grif: ERROR: failed to release workspace arrays.') 618 611 ! 619 612 END SUBROUTINE ldf_slp_grif … … 749 742 !! 750 743 !! ** Method : read the nammbf namelist and check the parameter 751 !! values called by tra_dmp at the first timestep (nit000)744 !! values called by tra_dmp at the first timestep (nit000) 752 745 !!---------------------------------------------------------------------- 753 746 INTEGER :: ji, jj, jk ! dummy loop indices … … 764 757 ALLOCATE( triadi_g(jpi,jpj,jpk,0:1,0:1) , triadj_g(jpi,jpj,jpk,0:1,0:1) , wslp2(jpi,jpj,jpk) , STAT=ierr ) 765 758 ALLOCATE( triadi (jpi,jpj,jpk,0:1,0:1) , triadj (jpi,jpj,jpk,0:1,0:1) , STAT=ierr ) 766 IF( ierr > 0 ) THEN 767 CALL ctl_stop( 'ldf_slp_init : unable to allocate Griffies operator slope ' ) ; RETURN 768 ENDIF 759 IF( ierr > 0 ) CALL ctl_stop( 'STOP', 'ldf_slp_init : unable to allocate Griffies operator slope' ) 760 IF( ldf_slp_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'ldf_slp_init : unable to allocate workspace arrays' ) 769 761 ! 770 762 IF( ln_dynldf_iso ) CALL ctl_stop( 'ldf_slp_init: Griffies operator on momentum not supported' ) 771 763 ! 772 IF( ( ln_traldf_hor .AND. ln_dynldf_hor ) .AND. ln_sco ) & 773 & CALL ctl_stop( 'ldf_slp_init: horizontal Griffies operator ', & 774 & 'in s-coordinate not supported' ) 764 IF( ( ln_traldf_hor .OR. ln_dynldf_hor ) .AND. ln_sco ) & 765 CALL ctl_stop( 'ldf_slp_init: horizontal Griffies operator in s-coordinate not supported' ) 775 766 ! 776 767 ELSE ! Madec operator : slopes at u-, v-, and w-points 777 768 ALLOCATE( uslp(jpi,jpj,jpk) , vslp(jpi,jpj,jpk) , wslpi(jpi,jpj,jpk) , wslpj(jpi,jpj,jpk) , & 778 769 & omlmask(jpi,jpj,jpk) , uslpml(jpi,jpj) , vslpml(jpi,jpj) , wslpiml(jpi,jpj) , wslpjml(jpi,jpj) , STAT=ierr ) 779 IF( ierr > 0 ) THEN 780 CALL ctl_stop( 'ldf_slp_init : unable to allocate Madec operator slope ' ) ; RETURN 781 ENDIF 770 IF( ierr > 0 ) CALL ctl_stop( 'STOP', 'ldf_slp_init : unable to allocate Madec operator slope ' ) 782 771 783 772 ! Direction of lateral diffusion (tracers and/or momentum) … … 790 779 !!gm I no longer understand this..... 791 780 IF( (ln_traldf_hor .OR. ln_dynldf_hor) .AND. .NOT. (lk_vvl .AND. ln_rstart) ) THEN 792 IF(lwp) THEN 793 WRITE(numout,*) ' Horizontal mixing in s-coordinate: slope = slope of s-surfaces' 794 ENDIF 781 IF(lwp) WRITE(numout,*) ' Horizontal mixing in s-coordinate: slope = slope of s-surfaces' 795 782 796 783 ! geopotential diffusion in s-coordinates on tracers and/or momentum … … 810 797 END DO 811 798 END DO 812 ! Lateral boundary conditions on the slopes 813 CALL lbc_lnk( uslp , 'U', -1. ) ; CALL lbc_lnk( vslp , 'V', -1. ) 814 CALL lbc_lnk( wslpi, 'W', -1. ) ; CALL lbc_lnk( wslpj, 'W', -1. ) 799 CALL lbc_lnk( uslp , 'U', -1. ) ; CALL lbc_lnk( vslp , 'V', -1. ) ! Lateral boundary conditions 800 CALL lbc_lnk( wslpi, 'W', -1. ) ; CALL lbc_lnk( wslpj, 'W', -1. ) 815 801 ENDIF 816 ENDIF ! 802 ENDIF 803 ! 817 804 END SUBROUTINE ldf_slp_init 818 805 -
branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/LDF/ldftra_oce.F90
r2590 r2618 4 4 !! Ocean physics : lateral tracer mixing coefficient defined in memory 5 5 !!===================================================================== 6 !! History : 9.0 ! 02-11 (G. Madec) Original code6 !! History : 9.0 ! 2002-11 (G. Madec) Original code 7 7 !!---------------------------------------------------------------------- 8 USE par_oce ! ocean parameters 8 USE par_oce ! ocean parameters 9 USE in_out_manager ! I/O manager 9 10 10 11 IMPLICIT NONE … … 34 35 35 36 #if defined key_traldf_c3d 36 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ahtt, ahtu, ahtv, ahtw !: ** 3D coefficients ** at T-, U-, V-,W-points37 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ahtt, ahtu, ahtv, ahtw !: ** 3D coefficients ** at T-,U-,V-,W-points 37 38 #elif defined key_traldf_c2d 38 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ahtt, ahtu, ahtv, ahtw !: ** 2D coefficients ** at T-, U-, V-,W-points39 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ahtt, ahtu, ahtv, ahtw !: ** 2D coefficients ** at T-,U-,V-,W-points 39 40 #elif defined key_traldf_c1d 40 REAL(wp), PUBLIC, DIMENSION(jpk) :: ahtt, ahtu, ahtv, ahtw !: ** 1D coefficients ** at T-, U-, V-, W-points ARPDBGjpk41 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ahtt, ahtu, ahtv, ahtw !: ** 1D coefficients ** at T-,U-,V-,W-points 41 42 #else 42 REAL(wp), PUBLIC :: ahtt, ahtu, ahtv, ahtw !: ** 0D coefficients ** at T-, U-, V-,W-points43 REAL(wp), PUBLIC :: ahtt, ahtu, ahtv, ahtw !: ** 0D coefficients ** at T-,U-,V-,W-points 43 44 #endif 44 45 45 46 46 #if defined key_traldf_eiv … … 49 49 !!---------------------------------------------------------------------- 50 50 LOGICAL, PUBLIC, PARAMETER :: lk_traldf_eiv = .TRUE. !: eddy induced velocity flag 51 51 52 ! !!! eddy coefficients at U-, V-, W-points [m2/s] 52 53 # if defined key_traldf_c3d 53 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: aeiu , aeiv, aeiw !: ** 3D coefficients ** at U-, V-, W-points [m2/s]54 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: aeiu , aeiv , aeiw !: ** 3D coefficients ** 54 55 # elif defined key_traldf_c2d 55 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: aeiu, aeiv, aeiw !: ** 2D coefficients ** at U-, V-, W-points [m2/s]56 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: aeiu , aeiv , aeiw !: ** 2D coefficients ** 56 57 # elif defined key_traldf_c1d 57 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: aeiu, aeiv, aeiw !: ** 1D coefficients ** at U-, V-, W-points [m2/s]58 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: aeiu , aeiv , aeiw !: ** 1D coefficients ** 58 59 # else 59 REAL(wp), PUBLIC :: aeiu, aeiv, aeiw !: ** 0D coefficients ** at U-, V-, W-points [m2/s]60 REAL(wp), PUBLIC :: aeiu , aeiv , aeiw !: ** 0D coefficients ** 60 61 # endif 61 62 # if defined key_diaeiv … … 75 76 !! $Id$ 76 77 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 77 !! =====================================================================78 !!---------------------------------------------------------------------- 78 79 CONTAINS 79 80 80 FUNCTION ldftra_oce_alloc()81 INTEGER FUNCTION ldftra_oce_alloc() 81 82 !!---------------------------------------------------------------------- 83 !! *** FUNCTION ldftra_oce_alloc *** 82 84 !!---------------------------------------------------------------------- 83 IMPLICIT None84 INTEGER :: ldftra_oce_alloc85 85 INTEGER, DIMENSION(3) :: ierr 86 86 !!---------------------------------------------------------------------- … … 88 88 89 89 #if defined key_traldf_c3d 90 ALLOCATE(ahtt(jpi,jpj,jpk), ahtu(jpi,jpj,jpk), ahtv(jpi,jpj,jpk), & 91 ahtw(jpi,jpj,jpk), Stat=ierr(1)) 90 ALLOCATE( ahtt(jpi,jpj,jpk) , ahtu(jpi,jpj,jpk) , ahtv(jpi,jpj,jpk) , ahtw(jpi,jpj,jpk) , STAT=ierr(1) ) 92 91 #elif defined key_traldf_c2d 93 ALLOCATE(ahtt(jpi,jpj), ahtu(jpi,jpj), ahtv(jpi,jpj), & 94 ahtw(jpi,jpj), Stat=ierr(1)) 92 ALLOCATE( ahtt(jpi,jpj ), ahtu(jpi,jpj) , ahtv(jpi,jpj ) , ahtw(jpi,jpj ) , STAT=ierr(1) ) 95 93 #elif defined key_traldf_c1d 96 ! No need to allocate arrays where extent only depends on jpk ARPDBGjpk94 ALLOCATE( ahtt( jpk) , ahtu( jpk) , ahtv( jpk) , ahtw( jpk) , STAT=ierr(1) ) 97 95 #endif 98 96 ! 99 97 #if defined key_traldf_eiv 100 101 #if defined key_traldf_c3d 102 ALLOCATE(aeiu(jpi,jpj,jpk), aeiv(jpi,jpj,jpk), aeiw(jpi,jpj,jpk), & 103 Stat=ierr(2)) 104 #elif defined key_traldf_c2d 105 ALLOCATE(aeiu(jpi,jpj), aeiv(jpi,jpj), aeiw(jpi,jpj), Stat=ierr(2)) 106 #elif defined key_traldf_c1d 107 ALLOCATE(aeiu(jpk), aeiv(jpk), aeiw(jpk), Stat=ierr(2)) 98 # if defined key_traldf_c3d 99 ALLOCATE( aeiu(jpi,jpj,jpk) , aeiv(jpi,jpj,jpk) , aeiw(jpi,jpj,jpk) , STAT=ierr(2) ) 100 # elif defined key_traldf_c2d 101 ALLOCATE( aeiu(jpi,jpj ) , aeiv(jpi,jpj ) , aeiw(jpi,jpj ) , STAT=ierr(2) ) 102 # elif defined key_traldf_c1d 103 ALLOCATE( aeiu( jpk) , aeiv( jpk) , aeiw( jpk) , STAT=ierr(2) ) 104 # endif 105 # if defined key_diaeiv 106 ALLOCATE( u_eiv(jpi,jpj,jpk), v_eiv(jpi,jpj,jpk), w_eiv(jpi,jpj,jpk), STAT=ierr(3)) 107 # endif 108 108 #endif 109 110 # if defined key_diaeiv 111 ALLOCATE(u_eiv(jpi,jpj,jpk), v_eiv(jpi,jpj,jpk), w_eiv(jpi,jpj,jpk), & 112 Stat=ierr(3)) 113 # endif 114 115 #endif 116 117 ldftra_oce_alloc = MAXVAL(ierr) 118 109 ldftra_oce_alloc = MAXVAL( ierr ) 110 IF( ldftra_oce_alloc /= 0 ) CALL ctl_warn('ldftra_oce_alloc: failed to allocate arrays') 111 ! 119 112 END FUNCTION ldftra_oce_alloc 120 113 121 !!---------------------------------------------------------------------- 122 114 !!===================================================================== 123 115 END MODULE ldftra_oce -
branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/OBC/obcdyn_bt.F90
r2528 r2618 16 16 17 17 !!---------------------------------------------------------------------------------- 18 !! * Modules used19 18 USE oce ! ocean dynamics and tracers 20 19 USE dom_oce ! ocean space and time domain … … 41 40 CONTAINS 42 41 43 SUBROUTINE obc_dyn_bt 42 SUBROUTINE obc_dyn_bt( kt ) 44 43 !!------------------------------------------------------------------------------ 45 44 !! SUBROUTINE obc_dyn_bt … … 55 54 !! open one (must be done in the param_obc.h90 file). 56 55 !! 57 !! ** Reference : 58 !! Flather, R. A., 1976, Mem. Soc. R. Sci. Liege, Ser. 6, 10, 141-164 59 !! 60 !! History : 61 !! 9.0 ! 05-12 (V. Garnier) original 56 !! ** Reference : Flather, R. A., 1976, Mem. Soc. R. Sci. Liege, Ser. 6, 10, 141-164 57 !! 58 !! History : 9.0 ! 05-12 (V. Garnier) original 62 59 !!---------------------------------------------------------------------- 63 60 !! * Arguments … … 321 318 !! 9.0 ! 05-12 (V. Garnier) original 322 319 !!------------------------------------------------------------------------------ 323 !! * Local declaration 324 INTEGER :: ji, jj, jk ! dummy loop indices 325 320 INTEGER :: ji, jj, jk ! dummy loop indices 326 321 !!------------------------------------------------------------------------------ 327 322 -
branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/OBC/obcfla.F90
r2528 r2618 5 5 !!====================================================================== 6 6 !! History : 2.0 ! 2005-12 (V. Garnier) original code 7 !! 3.3 ! 2010-11 (G. Madec) 7 !! 3.3 ! 2010-11 (G. Madec) 8 !! 4.0 ! 2011-02 (G. Madec) velocity & ssh passed in argument 8 9 !!---------------------------------------------------------------------- 9 10 #if defined key_obc && defined key_dynspg_ts … … 31 32 32 33 !!---------------------------------------------------------------------- 33 !! NEMO/OPA 3.3 , NEMO Consortium (2010)34 !! NEMO/OPA 4.0 , NEMO Consortium (2011) 34 35 !! $Id$ 35 36 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 37 38 CONTAINS 38 39 39 SUBROUTINE obc_fla_ts 40 SUBROUTINE obc_fla_ts( pua, pva, p_sshn, p_ssha ) 40 41 !!---------------------------------------------------------------------- 41 42 !! SUBROUTINE obc_fla_ts … … 52 53 !! ** Reference : Flather, R. A., 1976, Mem. Soc. R. Sci. Liege, Ser. 6, 10, 141-164 53 54 !!---------------------------------------------------------------------- 55 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua , pva ! after barotropic velocities 56 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: p_sshn, p_ssha ! before, now, after sea surface height 57 !!---------------------------------------------------------------------- 54 58 ! 55 IF( lp_obc_east ) CALL obc_fla_ts_east 56 IF( lp_obc_west ) CALL obc_fla_ts_west 57 IF( lp_obc_north ) CALL obc_fla_ts_north 58 IF( lp_obc_south ) CALL obc_fla_ts_south 59 IF( lp_obc_east ) CALL obc_fla_ts_east ( pua, pva, p_sshn, p_ssha ) 60 IF( lp_obc_west ) CALL obc_fla_ts_west ( pua, pva, p_sshn, p_ssha ) 61 IF( lp_obc_north ) CALL obc_fla_ts_north( pua, pva, p_sshn, p_ssha ) 62 IF( lp_obc_south ) CALL obc_fla_ts_south( pua, pva, p_sshn, p_ssha ) 59 63 ! 60 64 END SUBROUTINE obc_fla_ts 61 65 62 66 63 SUBROUTINE obc_fla_ts_east 67 SUBROUTINE obc_fla_ts_east( pua, pva, p_sshn, p_ssha ) 64 68 !!---------------------------------------------------------------------- 65 69 !! *** SUBROUTINE obc_fla_ts_east *** 66 70 !! 67 71 !! ** Purpose : Apply Flather's algorithm on east OBC velocities ua, va 68 !! Fix sea surface height ( sshn_e) on east open boundary72 !! Fix sea surface height (p_sshn) on east open boundary 69 73 !!---------------------------------------------------------------------- 74 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua , pva ! after barotropic velocities 75 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: p_sshn, p_ssha ! before, now, after sea surface height 76 ! 70 77 INTEGER :: ji, jj ! dummy loop indices 71 78 !!---------------------------------------------------------------------- … … 73 80 DO ji = nie0, nie1 74 81 DO jj = 1, jpj 75 ua_e(ji,jj) = ( ubtfoe(jj) * hur(ji,jj) + SQRT( grav*hur(ji,jj) ) &76 & * ( ( sshn_e(ji,jj) + sshn_e(ji+1,jj) ) * 0.5 - sshfoe(jj) ) ) * uemsk(jj,1)82 pua (ji,jj) = ( ubtfoe(jj) * hur(ji,jj) + SQRT( grav*hur(ji,jj) ) & 83 & * ( ( p_sshn(ji,jj) + p_sshn(ji+1,jj) ) * 0.5 - sshfoe(jj) ) ) * uemsk(jj,1) 77 84 sshfoe_b(ji,jj) = sshfoe_b(ji,jj) + SQRT( grav*hur(ji,jj) ) & 78 & * ( ( sshn_e(ji,jj) + sshn_e(ji+1,jj) ) * 0.5 - sshfoe(jj) ) * uemsk(jj,1)85 & * ( ( p_sshn(ji,jj) + p_sshn(ji+1,jj) ) * 0.5 - sshfoe(jj) ) * uemsk(jj,1) 79 86 END DO 80 87 END DO 81 88 DO ji = nie0p1, nie1p1 82 89 DO jj = 1, jpj 83 ssha_e(ji,jj) = ssha_e(ji,jj) * ( 1. - temsk(jj,1) ) + temsk(jj,1) * sshfoe(jj)84 va_e(ji,jj) = vbtfoe(jj) * hvr(ji,jj) * uemsk(jj,1)90 p_ssha(ji,jj) = p_ssha(ji,jj) * ( 1. - temsk(jj,1) ) + temsk(jj,1) * sshfoe(jj) 91 pva (ji,jj) = vbtfoe(jj) * hvr(ji,jj) * uemsk(jj,1) 85 92 END DO 86 93 END DO … … 89 96 90 97 91 SUBROUTINE obc_fla_ts_west 98 SUBROUTINE obc_fla_ts_west( pua, pva, p_sshn, p_ssha ) 92 99 !!---------------------------------------------------------------------- 93 100 !! *** SUBROUTINE obc_fla_ts_west *** 94 101 !! 95 102 !! ** Purpose : Apply Flather's algorithm on west OBC velocities ua, va 96 !! Fix sea surface height ( sshn_e) on west open boundary103 !! Fix sea surface height (p_sshn) on west open boundary 97 104 !!---------------------------------------------------------------------- 105 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua , pva ! after barotropic velocities 106 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: p_sshn, p_ssha ! before, now, after sea surface height 107 ! 98 108 INTEGER :: ji, jj ! dummy loop indices 99 109 !!---------------------------------------------------------------------- … … 101 111 DO ji = niw0, niw1 102 112 DO jj = 1, jpj 103 ua_e(ji,jj) = ( ubtfow(jj) * hur(ji,jj) - sqrt( grav * hur(ji,jj) ) &104 & * ( ( sshn_e(ji,jj) + sshn_e(ji+1,jj) ) * 0.5 - sshfow(jj) ) ) * uwmsk(jj,1)105 va_e(ji,jj) = vbtfow(jj) * hvr(ji,jj) * uwmsk(jj,1)113 pua (ji,jj) = ( ubtfow(jj) * hur(ji,jj) - sqrt( grav * hur(ji,jj) ) & 114 & * ( ( p_sshn(ji,jj) + p_sshn(ji+1,jj) ) * 0.5 - sshfow(jj) ) ) * uwmsk(jj,1) 115 pva (ji,jj) = vbtfow(jj) * hvr(ji,jj) * uwmsk(jj,1) 106 116 sshfow_b(ji,jj) = sshfow_b(ji,jj) - SQRT( grav * hur(ji,jj) ) & 107 & * ( ( sshn_e(ji,jj) + sshn_e(ji+1,jj) ) * 0.5 - sshfow(jj) ) * uwmsk(jj,1)108 ssha_e (ji,jj) = ssha_e(ji,jj) * ( 1. - twmsk(jj,1) ) + twmsk(jj,1)*sshfow(jj)117 & * ( ( p_sshn(ji,jj) + p_sshn(ji+1,jj) ) * 0.5 - sshfow(jj) ) * uwmsk(jj,1) 118 p_ssha (ji,jj) = p_ssha(ji,jj) * ( 1. - twmsk(jj,1) ) + twmsk(jj,1)*sshfow(jj) 109 119 END DO 110 120 END DO … … 113 123 114 124 115 SUBROUTINE obc_fla_ts_north 125 SUBROUTINE obc_fla_ts_north( pua, pva, p_sshn, p_ssha ) 116 126 !!---------------------------------------------------------------------- 117 127 !! SUBROUTINE obc_fla_ts_north 118 128 !! 119 129 !! ** Purpose : Apply Flather's algorithm on north OBC velocities ua, va 120 !! Fix sea surface height ( sshn_e) on north open boundary130 !! Fix sea surface height (p_sshn) on north open boundary 121 131 !!---------------------------------------------------------------------- 132 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua , pva ! after barotropic velocities 133 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: p_sshn, p_ssha ! before, now, after sea surface height 134 ! 122 135 INTEGER :: ji, jj ! dummy loop indices 123 136 !!---------------------------------------------------------------------- … … 125 138 DO jj = njn0, njn1 126 139 DO ji = 1, jpi 127 va_e(ji,jj) = ( vbtfon(ji) * hvr(ji,jj) + sqrt( grav * hvr(ji,jj) ) &128 & * ( ( sshn_e(ji,jj) + sshn_e(ji,jj+1) ) * 0.5 - sshfon(ji) ) ) * vnmsk(ji,1)140 pva (ji,jj) = ( vbtfon(ji) * hvr(ji,jj) + sqrt( grav * hvr(ji,jj) ) & 141 & * ( ( p_sshn(ji,jj) + p_sshn(ji,jj+1) ) * 0.5 - sshfon(ji) ) ) * vnmsk(ji,1) 129 142 sshfon_b(ji,jj) = sshfon_b(ji,jj) + sqrt( grav * hvr(ji,jj) ) & 130 & * ( ( sshn_e(ji,jj) + sshn_e(ji,jj+1) ) * 0.5 - sshfon(ji) ) * vnmsk(ji,1)143 & * ( ( p_sshn(ji,jj) + p_sshn(ji,jj+1) ) * 0.5 - sshfon(ji) ) * vnmsk(ji,1) 131 144 END DO 132 145 END DO 133 146 DO jj = njn0p1, njn1p1 134 147 DO ji = 1, jpi 135 ssha_e(ji,jj) = ssha_e(ji,jj) * ( 1. - tnmsk(ji,1) ) + sshfon(ji) * tnmsk(ji,1)136 ua_e(ji,jj) = ubtfon(ji) * hur(ji,jj) * vnmsk(ji,1)148 p_ssha(ji,jj) = p_ssha(ji,jj) * ( 1. - tnmsk(ji,1) ) + sshfon(ji) * tnmsk(ji,1) 149 pua (ji,jj) = ubtfon(ji) * hur(ji,jj) * vnmsk(ji,1) 137 150 END DO 138 151 END DO … … 141 154 142 155 143 SUBROUTINE obc_fla_ts_south 156 SUBROUTINE obc_fla_ts_south( pua, pva, p_sshn, p_ssha ) 144 157 !!---------------------------------------------------------------------- 145 158 !! SUBROUTINE obc_fla_ts_south 146 159 !! 147 160 !! ** Purpose : Apply Flather's algorithm on south OBC velocities ua, va 148 !! Fix sea surface height ( sshn_e) on south open boundary161 !! Fix sea surface height (p_sshn) on south open boundary 149 162 !!---------------------------------------------------------------------- 163 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua , pva ! after barotropic velocities 164 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: p_sshn, p_ssha ! before, now, after sea surface height 165 ! 150 166 INTEGER :: ji, jj ! dummy loop indices 151 167 !!---------------------------------------------------------------------- … … 153 169 DO jj = njs0, njs1 154 170 DO ji = 1, jpi 155 va_e(ji,jj) = ( vbtfos(ji) * hvr(ji,jj) - sqrt( grav * hvr(ji,jj) ) &156 & * ( ( sshn_e(ji,jj) + sshn_e(ji,jj+1) ) * 0.5 - sshfos(ji) ) ) * vsmsk(ji,1)157 ua_e(ji,jj) = ubtfos(ji) * hur(ji,jj) * vsmsk(ji,1)171 pva (ji,jj) = ( vbtfos(ji) * hvr(ji,jj) - sqrt( grav * hvr(ji,jj) ) & 172 & * ( ( p_sshn(ji,jj) + p_sshn(ji,jj+1) ) * 0.5 - sshfos(ji) ) ) * vsmsk(ji,1) 173 pua (ji,jj) = ubtfos(ji) * hur(ji,jj) * vsmsk(ji,1) 158 174 sshfos_b(ji,jj) = sshfos_b(ji,jj) - sqrt( grav * hvr(ji,jj) ) & 159 & * ( ( sshn_e(ji,jj) + sshn_e(ji,jj+1) ) * 0.5 - sshfos(ji) ) * vsmsk(ji,1)160 ssha_e (ji,jj) = ssha_e(ji,jj) * (1. - tsmsk(ji,1) ) + tsmsk(ji,1) * sshfos(ji)175 & * ( ( p_sshn(ji,jj) + p_sshn(ji,jj+1) ) * 0.5 - sshfos(ji) ) * vsmsk(ji,1) 176 p_ssha (ji,jj) = p_ssha(ji,jj) * (1. - tsmsk(ji,1) ) + tsmsk(ji,1) * sshfos(ji) 161 177 END DO 162 178 END DO … … 170 186 CONTAINS 171 187 172 SUBROUTINE obc_fla_ts 173 WRITE(*,*) 'obc_fla_ts: You should not have seen this print! error?' 188 SUBROUTINE obc_fla_ts( pua, pva, p_sshn, p_ssha ) 189 REAL, DIMENSION(:,:):: pua, pva, p_sshn, p_ssha 190 WRITE(*,*) 'obc_fla_ts: You should not have seen this print! error?', pua(1,1), pva(1,1), p_sshn(1,1), p_ssha(1,1) 174 191 END SUBROUTINE obc_fla_ts 175 192 #endif -
branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfkpp.F90
r2616 r2618 1315 1315 USE trc 1316 1316 USE prtctl_trc ! Print control 1317 ! ! * Arguments1318 INTEGER , INTENT( in ) :: kt! ocean time-step index1319 ! ! * Local declarations1317 ! 1318 INTEGER, INTENT(in) :: kt ! ocean time-step index 1319 ! 1320 1320 INTEGER :: ji, jj, jk, jn ! Dummy loop indices 1321 1321 REAL(wp) :: ztra, zflx … … 1359 1359 ENDIF 1360 1360 ! 1361 END SUBROUTINE trc_kpp 1362 1363 #else 1364 !!---------------------------------------------------------------------- 1365 !! NO 'key_top' DUMMY routine No TOP models 1366 !!---------------------------------------------------------------------- 1367 SUBROUTINE trc_kpp( kt ) ! Dummy routine 1368 INTEGER, INTENT(in) :: kt ! ocean time-step index 1369 WRITE(*,*) 'tra_kpp: You should not have seen this print! error?', kt 1361 1370 END SUBROUTINE trc_kpp 1362 1371 #endif -
branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90
r2617 r2618 467 467 USE diawri, ONLY: dia_wri_alloc 468 468 USE dom_oce, ONLY: dom_oce_alloc 469 USE ldfdyn_oce, ONLY: ldfdyn_oce_alloc 470 USE ldftra_oce, ONLY: ldftra_oce_alloc 471 472 469 473 USE dynzdf_exp, ONLY: dyn_zdf_exp_alloc 470 #if defined key_floats || defined key_esopa471 USE flo_oce, ONLY: flo_oce_alloc472 #endif473 #if defined key_floats || defined key_esopa474 USE flowri, ONLY: flo_wri_alloc475 #endif476 474 USE geo2ocean, ONLY: geo2oce_alloc 477 USE ldfdyn_oce, ONLY: ldfdyn_oce_alloc478 #if defined key_ldfslp || defined key_esopa479 USE ldfslp, ONLY: ldf_slp_alloc480 #endif481 USE ldftra_oce, ONLY: ldftra_oce_alloc482 475 #if defined key_mpp_mpi 483 476 USE lib_mpp, ONLY: lib_mpp_alloc 484 477 #endif 485 478 #if defined key_obc 486 USE obcdta , ONLY: obc_dta_alloc479 USE obcdta , ONLY: obc_dta_alloc 487 480 USE obc_oce, ONLY: obc_oce_alloc 488 481 #endif 489 USE oce, ONLY: oce_alloc490 482 USE sbcblk_clio, ONLY: sbc_blk_clio_alloc 491 483 #if defined key_oasis3 || defined key_oasis4 … … 563 555 !!---------------------------------------------------------------------- 564 556 565 ierr = 0 566 567 ierr = ierr + dia_wri_alloc() 568 ierr = ierr + dom_oce_alloc() ! ocean domain 557 ierr = oce_alloc () ! ocean 558 ierr = ierr + dia_wri_alloc () 559 ierr = ierr + dom_oce_alloc () ! ocean domain 560 ierr = ierr + ldfdyn_oce_alloc() ! ocean lateral physics : dynamics 561 ierr = ierr + ldftra_oce_alloc() ! ocean lateral physics : tracers 569 562 ierr = ierr + zdf_oce_alloc() ! ocean vertical physics 570 563 … … 572 565 573 566 ierr = ierr + dyn_zdf_exp_alloc() 574 #if defined key_floats || defined key_esopa575 ierr = ierr + flo_oce_alloc()576 ierr = ierr + flo_wri_alloc()577 #endif578 567 ierr = ierr + geo2oce_alloc() 579 ierr = ierr + ldfdyn_oce_alloc()580 #if defined key_ldfslp || defined key_esopa581 ierr = ierr + ldf_slp_alloc()582 #endif583 ierr = ierr + ldftra_oce_alloc()584 568 #if defined key_mpp_mpi 585 569 ierr = ierr + lib_mpp_alloc() … … 589 573 ierr = ierr + obc_oce_alloc() 590 574 #endif 591 ierr = ierr + oce_alloc()592 575 ierr = ierr + sbc_blk_clio_alloc() 593 576 #if defined key_oasis3 || defined key_oasis4 -
branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/oce.F90
r2590 r2618 8 8 !! 3.3 ! 2010-09 (C. Ethe) TRA-TRC merge: add ts, gtsu, gtsv 4D arrays 9 9 !!---------------------------------------------------------------------- 10 USE par_oce ! ocean parameters 10 USE par_oce ! ocean parameters 11 USE in_out_manager ! I/O manager 11 12 12 13 IMPLICIT NONE … … 15 16 PUBLIC oce_alloc ! routine called by nemo_init in nemogcm.F90 16 17 17 LOGICAL 18 LOGICAL, PUBLIC :: l_traldf_rot = .FALSE. !: rotated laplacian operator for lateral diffusion 18 19 19 20 !! dynamics and tracer fields ! before ! now ! after ! the after trends becomes the fields … … 38 39 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sshv_b , sshv_n , sshv_a !: sea surface height at u-point [m] 39 40 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sshf_n !: sea surface height at f-point [m] 41 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sshn_b !: before field without time-filter 40 42 ! 41 43 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: spgu, spgv !: horizontal surface pressure gradient … … 47 49 48 50 !!---------------------------------------------------------------------- 49 !! NEMO/OPA 3.3 , NEMO Consortium (2010)51 !! NEMO/OPA 4.0 , NEMO Consortium (2011) 50 52 !! $Id$ 51 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)52 !! ======================================================================53 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 54 !!---------------------------------------------------------------------- 53 55 CONTAINS 54 56 55 FUNCTION oce_alloc() 56 IMPLICIT none 57 INTEGER :: oce_alloc 58 INTEGER :: ierr(2) 59 60 ! The Allocate statement is broken up to prevent excessive 61 ! line lengths 62 ALLOCATE(ub(jpi,jpj,jpk), un(jpi,jpj,jpk), ua(jpi,jpj,jpk), & 63 vb(jpi,jpj,jpk), vn(jpi,jpj,jpk), va(jpi,jpj,jpk), & 64 wn(jpi,jpj,jpk), & 65 rotb(jpi,jpj,jpk), rotn(jpi,jpj,jpk), & 66 hdivb(jpi,jpj,jpk), hdivn(jpi,jpj,jpk), & 67 tb(jpi,jpj,jpk), tn(jpi,jpj,jpk), ta(jpi,jpj,jpk), & 68 sb(jpi,jpj,jpk), sn(jpi,jpj,jpk), sa(jpi,jpj,jpk), & 69 tsb(jpi,jpj,jpk,jpts),tsn(jpi,jpj,jpk,jpts),tsa(jpi,jpj,jpk,jpts),& 70 rn2b(jpi,jpj,jpk), rn2(jpi,jpj,jpk), & 71 ! 72 Stat=ierr(1)) 73 74 ALLOCATE(rhd(jpi,jpj,jpk), & 75 rhop(jpi,jpj,jpk), & 76 ! 77 sshb(jpi,jpj), sshn(jpi,jpj), ssha(jpi,jpj), & 78 sshu_b(jpi,jpj), sshu_n(jpi,jpj), sshu_a(jpi,jpj), & 79 sshv_b(jpi,jpj), sshv_n(jpi,jpj), sshv_a(jpi,jpj), & 80 sshf_n(jpi,jpj), & 81 ! 82 spgu(jpi,jpj), spgv(jpi,jpj), & 83 ! 84 gtsu(jpi,jpj,jpts), gtsv(jpi,jpj,jpts), & 85 gru(jpi,jpj), grv(jpi,jpj), & 86 ! 87 Stat=ierr(2)) 88 89 oce_alloc = maxval(ierr) 90 57 INTEGER FUNCTION oce_alloc() 58 !!---------------------------------------------------------------------- 59 INTEGER :: ierr(2) 60 !!---------------------------------------------------------------------- 61 ! 62 ALLOCATE( ub (jpi,jpj,jpk) , un (jpi,jpj,jpk) , ua(jpi,jpj,jpk) , & 63 & vb (jpi,jpj,jpk) , vn (jpi,jpj,jpk) , va(jpi,jpj,jpk) , & 64 & wn (jpi,jpj,jpk) , & 65 & rotb (jpi,jpj,jpk) , rotn (jpi,jpj,jpk) , & 66 & hdivb(jpi,jpj,jpk) , hdivn(jpi,jpj,jpk) , & 67 & tb (jpi,jpj,jpk) , tn (jpi,jpj,jpk) , ta(jpi,jpj,jpk) , & 68 & sb (jpi,jpj,jpk) , sn (jpi,jpj,jpk) , sa (jpi,jpj,jpk) , & 69 & tsb (jpi,jpj,jpk,jpts) , tsn (jpi,jpj,jpk,jpts) , tsa(jpi,jpj,jpk,jpts) , & 70 & rn2b (jpi,jpj,jpk) , rn2 (jpi,jpj,jpk) , STAT=ierr(1) ) 71 ! 72 ALLOCATE(rhd (jpi,jpj,jpk) , & 73 & rhop(jpi,jpj,jpk) , & 74 & sshb (jpi,jpj) , sshn (jpi,jpj) , ssha (jpi,jpj) , & 75 & sshu_b(jpi,jpj) , sshu_n(jpi,jpj) , sshu_a(jpi,jpj) , & 76 & sshv_b(jpi,jpj) , sshv_n(jpi,jpj) , sshv_a(jpi,jpj) , & 77 & sshf_n(jpi,jpj) , & 78 & sshn_b(jpi,jpj) , & 79 & spgu (jpi,jpj) , spgv(jpi,jpj) , & 80 & gtsu(jpi,jpj,jpts), gtsv(jpi,jpj,jpts), & 81 & gru(jpi,jpj) , grv(jpi,jpj) , STAT=ierr(2) ) 82 ! 83 oce_alloc = maxval( ierr ) 84 IF( oce_alloc /= 0 ) CALL ctl_warn('oce_alloc: failed to allocate arrays') 85 ! 91 86 END FUNCTION oce_alloc 92 87 88 !!====================================================================== 93 89 END MODULE oce
Note: See TracChangeset
for help on using the changeset viewer.