Changeset 3294 for trunk/NEMOGCM/NEMO/OPA_SRC/SBC
- Timestamp:
- 2012-01-28T17:44:18+01:00 (12 years ago)
- Location:
- trunk/NEMOGCM/NEMO/OPA_SRC/SBC
- Files:
-
- 20 edited
- 7 copied
Legend:
- Unmodified
- Added
- Removed
-
trunk/NEMOGCM/NEMO/OPA_SRC/SBC/albedo.F90
r2715 r3294 19 19 USE in_out_manager ! I/O manager 20 20 USE lib_mpp ! MPP library 21 USE wrk_nemo ! work arrays 21 22 22 23 IMPLICIT NONE … … 65 66 !! References : Shine and Hendersson-Sellers 1985, JGR, 90(D1), 2243-2250. 66 67 !!---------------------------------------------------------------------- 67 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released68 USE wrk_nemo, ONLY: wrk_3d_6 , wrk_3d_7 ! 3D workspace69 !!70 68 REAL(wp), INTENT(in ), DIMENSION(:,:,:) :: pt_ice ! ice surface temperature (Kelvin) 71 69 REAL(wp), INTENT(in ), DIMENSION(:,:,:) :: ph_ice ! sea-ice thickness … … 91 89 ijpl = SIZE( pt_ice, 3 ) ! number of ice categories 92 90 93 IF( wrk_in_use(3, 6,7) ) THEN 94 CALL ctl_stop('albedo_ice: requested workspace arrays are unavailable') ; RETURN 95 ENDIF 96 ! Associate pointers with sub-arrays of workspace arrays 97 zalbfz => wrk_3d_6(:,:,1:ijpl) 98 zficeth => wrk_3d_7(:,:,1:ijpl) 91 CALL wrk_alloc( jpi,jpj,ijpl, zalbfz, zficeth ) 99 92 100 93 IF( albd_init == 0 ) CALL albedo_init ! initialization … … 173 166 pa_ice_os(:,:,:) = pa_ice_cs(:,:,:) + rn_cloud ! Oberhuber correction 174 167 ! 175 IF( wrk_not_released(3, 6,7) ) CALL ctl_stop('albedo_ice: failed to release workspace arrays')168 CALL wrk_dealloc( jpi,jpj,ijpl, zalbfz, zficeth ) 176 169 ! 177 170 END SUBROUTINE albedo_ice -
trunk/NEMOGCM/NEMO/OPA_SRC/SBC/cpl_oasis3.F90
r2715 r3294 13 13 !! " " ! 06-01 (W. Park) modification of physical part 14 14 !! " " ! 06-02 (R. Redler, W. Park) buffer array fix for root exchange 15 !! 3.4 ! 11-11 (C. Harris) Changes to allow mutiple category fields 15 16 !!---------------------------------------------------------------------- 16 17 #if defined key_oasis3 … … 52 53 INTEGER, PARAMETER :: nmaxfld=40 ! Maximum number of coupling fields 53 54 54 TYPE, PUBLIC :: FLD_CPL !: Type for coupling field information 55 LOGICAL :: laction ! To be coupled or not 56 CHARACTER(len = 8) :: clname ! Name of the coupling field 57 CHARACTER(len = 1) :: clgrid ! Grid type 58 REAL(wp) :: nsgn ! Control of the sign change 59 INTEGER :: nid ! Id of the field 55 TYPE, PUBLIC :: FLD_CPL !: Type for coupling field information 56 LOGICAL :: laction ! To be coupled or not 57 CHARACTER(len = 8) :: clname ! Name of the coupling field 58 CHARACTER(len = 1) :: clgrid ! Grid type 59 REAL(wp) :: nsgn ! Control of the sign change 60 INTEGER, DIMENSION(9) :: nid ! Id of the field (no more than 9 categories) 61 INTEGER :: nct ! Number of categories in field 60 62 END TYPE FLD_CPL 61 63 … … 118 120 INTEGER :: paral(5) ! OASIS3 box partition 119 121 INTEGER :: ishape(2,2) ! shape of arrays passed to PSMILe 120 INTEGER :: ji ! local loop indicees 122 INTEGER :: ji,jc ! local loop indicees 123 CHARACTER(LEN=8) :: zclname 121 124 !!-------------------------------------------------------------------- 122 125 … … 164 167 DO ji = 1, ksnd 165 168 IF ( ssnd(ji)%laction ) THEN 166 CALL prism_def_var_proto (ssnd(ji)%nid, ssnd(ji)%clname, id_part, (/ 2, 0/), & 167 & PRISM_Out , ishape , PRISM_REAL, nerror) 168 IF ( nerror /= PRISM_Ok ) THEN 169 WRITE(numout,*) 'Failed to define transient ', ji, TRIM(ssnd(ji)%clname) 170 CALL prism_abort_proto ( ssnd(ji)%nid, 'cpl_prism_define', 'Failure in prism_def_var') 171 ENDIF 169 DO jc = 1, ssnd(ji)%nct 170 IF ( ssnd(ji)%nct .gt. 1 ) THEN 171 WRITE(zclname,'( a7, i1)') ssnd(ji)%clname,jc 172 ELSE 173 zclname=ssnd(ji)%clname 174 ENDIF 175 WRITE(numout,*) "Define",ji,jc,zclname," for",PRISM_Out 176 CALL prism_def_var_proto (ssnd(ji)%nid(jc), zclname, id_part, (/ 2, 0/), & 177 PRISM_Out, ishape, PRISM_REAL, nerror) 178 IF ( nerror /= PRISM_Ok ) THEN 179 WRITE(numout,*) 'Failed to define transient ', ji, TRIM(zclname) 180 CALL prism_abort_proto ( ssnd(ji)%nid(jc), 'cpl_prism_define', 'Failure in prism_def_var') 181 ENDIF 182 END DO 172 183 ENDIF 173 184 END DO … … 177 188 DO ji = 1, krcv 178 189 IF ( srcv(ji)%laction ) THEN 179 CALL prism_def_var_proto ( srcv(ji)%nid, srcv(ji)%clname, id_part, (/ 2, 0/), & 180 & PRISM_In , ishape , PRISM_REAL, nerror) 181 IF ( nerror /= PRISM_Ok ) THEN 182 WRITE(numout,*) 'Failed to define transient ', ji, TRIM(srcv(ji)%clname) 183 CALL prism_abort_proto ( srcv(ji)%nid, 'cpl_prism_define', 'Failure in prism_def_var') 184 ENDIF 190 DO jc = 1, srcv(ji)%nct 191 IF ( srcv(ji)%nct .gt. 1 ) THEN 192 WRITE(zclname,'( a7, i1)') srcv(ji)%clname,jc 193 ELSE 194 zclname=srcv(ji)%clname 195 ENDIF 196 WRITE(numout,*) "Define",ji,jc,zclname," for",PRISM_In 197 CALL prism_def_var_proto ( srcv(ji)%nid(jc), zclname, id_part, (/ 2, 0/), & 198 & PRISM_In , ishape , PRISM_REAL, nerror) 199 IF ( nerror /= PRISM_Ok ) THEN 200 WRITE(numout,*) 'Failed to define transient ', ji, TRIM(zclname) 201 CALL prism_abort_proto ( srcv(ji)%nid(jc), 'cpl_prism_define', 'Failure in prism_def_var') 202 ENDIF 203 END DO 185 204 ENDIF 186 205 END DO … … 203 222 !! like sst or ice cover to the coupler or remote application. 204 223 !!---------------------------------------------------------------------- 205 INTEGER , INTENT(in ) :: kid ! variable index in the array 206 INTEGER , INTENT( out) :: kinfo ! OASIS3 info argument 207 INTEGER , INTENT(in ) :: kstep ! ocean time-step in seconds 208 REAL(wp), DIMENSION(:,:), INTENT(in ) :: pdata 224 INTEGER , INTENT(in ) :: kid ! variable index in the array 225 INTEGER , INTENT( out) :: kinfo ! OASIS3 info argument 226 INTEGER , INTENT(in ) :: kstep ! ocean time-step in seconds 227 REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pdata 228 !! 229 INTEGER :: jc ! local loop index 209 230 !!-------------------------------------------------------------------- 210 231 ! 211 232 ! snd data to OASIS3 212 233 ! 213 CALL prism_put_proto ( ssnd(kid)%nid, kstep, pdata(nldi:nlei, nldj:nlej), kinfo ) 214 215 IF ( ln_ctl ) THEN 216 IF ( kinfo == PRISM_Sent .OR. kinfo == PRISM_ToRest .OR. & 217 & kinfo == PRISM_SentOut .OR. kinfo == PRISM_ToRestOut ) THEN 218 WRITE(numout,*) '****************' 219 WRITE(numout,*) 'prism_put_proto: Outgoing ', ssnd(kid)%clname 220 WRITE(numout,*) 'prism_put_proto: ivarid ', ssnd(kid)%nid 221 WRITE(numout,*) 'prism_put_proto: kstep ', kstep 222 WRITE(numout,*) 'prism_put_proto: info ', kinfo 223 WRITE(numout,*) ' - Minimum value is ', MINVAL(pdata) 224 WRITE(numout,*) ' - Maximum value is ', MAXVAL(pdata) 225 WRITE(numout,*) ' - Sum value is ', SUM(pdata) 226 WRITE(numout,*) '****************' 234 DO jc = 1, ssnd(kid)%nct 235 236 CALL prism_put_proto ( ssnd(kid)%nid(jc), kstep, pdata(nldi:nlei, nldj:nlej,jc), kinfo ) 237 238 IF ( ln_ctl ) THEN 239 IF ( kinfo == PRISM_Sent .OR. kinfo == PRISM_ToRest .OR. & 240 & kinfo == PRISM_SentOut .OR. kinfo == PRISM_ToRestOut ) THEN 241 WRITE(numout,*) '****************' 242 WRITE(numout,*) 'prism_put_proto: Outgoing ', ssnd(kid)%clname 243 WRITE(numout,*) 'prism_put_proto: ivarid ', ssnd(kid)%nid(jc) 244 WRITE(numout,*) 'prism_put_proto: kstep ', kstep 245 WRITE(numout,*) 'prism_put_proto: info ', kinfo 246 WRITE(numout,*) ' - Minimum value is ', MINVAL(pdata(:,:,jc)) 247 WRITE(numout,*) ' - Maximum value is ', MAXVAL(pdata(:,:,jc)) 248 WRITE(numout,*) ' - Sum value is ', SUM(pdata(:,:,jc)) 249 WRITE(numout,*) '****************' 250 ENDIF 227 251 ENDIF 228 ENDIF 252 253 ENDDO 229 254 ! 230 255 END SUBROUTINE cpl_prism_snd … … 238 263 !! like stresses and fluxes from the coupler or remote application. 239 264 !!---------------------------------------------------------------------- 240 INTEGER , INTENT(in ) :: kid ! variable index in the array 241 INTEGER , INTENT(in ) :: kstep ! ocean time-step in seconds 242 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pdata ! IN to keep the value if nothing is done 243 INTEGER , INTENT( out) :: kinfo ! OASIS3 info argument 244 !! 245 LOGICAL :: llaction 265 INTEGER , INTENT(in ) :: kid ! variable index in the array 266 INTEGER , INTENT(in ) :: kstep ! ocean time-step in seconds 267 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pdata ! IN to keep the value if nothing is done 268 INTEGER , INTENT( out) :: kinfo ! OASIS3 info argument 269 !! 270 INTEGER :: jc ! local loop index 271 LOGICAL :: llaction 246 272 !!-------------------------------------------------------------------- 247 273 ! 248 274 ! receive local data from OASIS3 on every process 249 275 ! 250 CALL prism_get_proto ( srcv(kid)%nid, kstep, exfld, kinfo ) 251 252 llaction = .false. 253 IF( kinfo == PRISM_Recvd .OR. kinfo == PRISM_FromRest .OR. & 254 kinfo == PRISM_RecvOut .OR. kinfo == PRISM_FromRestOut ) llaction = .TRUE. 255 256 IF ( ln_ctl ) WRITE(numout,*) "llaction, kinfo, kstep, ivarid: " , llaction, kinfo, kstep, srcv(kid)%nid 257 258 IF ( llaction ) THEN 259 260 kinfo = OASIS_Rcv 261 pdata(nldi:nlei, nldj:nlej) = exfld(:,:) 262 263 !--- Fill the overlap areas and extra hallows (mpp) 264 !--- check periodicity conditions (all cases) 265 CALL lbc_lnk( pdata, srcv(kid)%clgrid, srcv(kid)%nsgn ) 266 267 IF ( ln_ctl ) THEN 268 WRITE(numout,*) '****************' 269 WRITE(numout,*) 'prism_get_proto: Incoming ', srcv(kid)%clname 270 WRITE(numout,*) 'prism_get_proto: ivarid ' , srcv(kid)%nid 271 WRITE(numout,*) 'prism_get_proto: kstep', kstep 272 WRITE(numout,*) 'prism_get_proto: info ', kinfo 273 WRITE(numout,*) ' - Minimum value is ', MINVAL(pdata) 274 WRITE(numout,*) ' - Maximum value is ', MAXVAL(pdata) 275 WRITE(numout,*) ' - Sum value is ', SUM(pdata) 276 WRITE(numout,*) '****************' 276 DO jc = 1, srcv(kid)%nct 277 278 CALL prism_get_proto ( srcv(kid)%nid(jc), kstep, exfld, kinfo ) 279 280 llaction = .false. 281 IF( kinfo == PRISM_Recvd .OR. kinfo == PRISM_FromRest .OR. & 282 kinfo == PRISM_RecvOut .OR. kinfo == PRISM_FromRestOut ) llaction = .TRUE. 283 284 IF ( ln_ctl ) WRITE(numout,*) "llaction, kinfo, kstep, ivarid: " , llaction, kinfo, kstep, srcv(kid)%nid(jc) 285 286 IF ( llaction ) THEN 287 288 kinfo = OASIS_Rcv 289 pdata(nldi:nlei, nldj:nlej,jc) = exfld(:,:) 290 291 !--- Fill the overlap areas and extra hallows (mpp) 292 !--- check periodicity conditions (all cases) 293 CALL lbc_lnk( pdata(:,:,jc), srcv(kid)%clgrid, srcv(kid)%nsgn ) 294 295 IF ( ln_ctl ) THEN 296 WRITE(numout,*) '****************' 297 WRITE(numout,*) 'prism_get_proto: Incoming ', srcv(kid)%clname 298 WRITE(numout,*) 'prism_get_proto: ivarid ' , srcv(kid)%nid(jc) 299 WRITE(numout,*) 'prism_get_proto: kstep', kstep 300 WRITE(numout,*) 'prism_get_proto: info ', kinfo 301 WRITE(numout,*) ' - Minimum value is ', MINVAL(pdata(:,:,jc)) 302 WRITE(numout,*) ' - Maximum value is ', MAXVAL(pdata(:,:,jc)) 303 WRITE(numout,*) ' - Sum value is ', SUM(pdata(:,:,jc)) 304 WRITE(numout,*) '****************' 305 ENDIF 306 307 ELSE 308 kinfo = OASIS_idle 277 309 ENDIF 278 279 ELSE 280 kinfo = OASIS_idle 281 ENDIF 310 311 ENDDO 282 312 ! 283 313 END SUBROUTINE cpl_prism_rcv -
trunk/NEMOGCM/NEMO/OPA_SRC/SBC/cpl_oasis4.F90
r2715 r3294 32 32 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 33 33 USE lib_mpp ! MPP library 34 USE wrk_nemo ! work arrays 34 35 35 36 IMPLICIT NONE … … 111 112 !! ** Method : OASIS4 MPI communication 112 113 !!-------------------------------------------------------------------- 113 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released114 USE wrk_nemo, ONLY: zclo => wrk_3d_1, zcla => wrk_3d_2115 USE wrk_nemo, ONLY: zlon => wrk_2d_1, zlat => wrk_2d_2116 !117 114 INTEGER, INTENT(in) :: krcv, ksnd ! Number of received and sent coupling fields 118 115 ! … … 145 142 TYPE(PRISM_Time_struct) :: tmpdate 146 143 INTEGER :: idate_incr ! date increment 147 !!-------------------------------------------------------------------- 148 149 IF( wrk_in_use(3, 1,2) .OR. wrk_in_use(2, 1,2) )THEN 150 CALL ctl_stop('cpl_prism_define: ERROR: requested workspace arrays are unavailable.') ; RETURN 151 ENDIF 144 REAL(wp), POINTER, DIMENSION(:,:) :: zlon, zlat 145 REAL(wp), POINTER, DIMENSION(:,:,:) :: zclo, zcla 146 !!-------------------------------------------------------------------- 147 148 CALL wrk_alloc( jpi,jpj, zlon, zlat ) 149 CALL wrk_alloc( jpi,jpj,jpk, zclo, zcla ) 152 150 153 151 IF(lwp) WRITE(numout,*) … … 322 320 IF ( nerror /= PRISM_Success ) CALL prism_abort ( ncomp_id, 'cpl_prism_define', 'Failure in prism_enddef') 323 321 324 IF( wrk_not_released(3, 1,2) .OR. &325 wrk_not_released(2, 1,2) ) CALL ctl_stop('cpl_prism_define: failed to release workspace arrays')322 CALL wrk_dealloc( jpi,jpj, zlon, zlat ) 323 CALL wrk_dealloc( jpi,jpj,jpk, zclo, zcla ) 326 324 ! 327 325 END SUBROUTINE cpl_prism_define -
trunk/NEMOGCM/NEMO/OPA_SRC/SBC/fldread.F90
r2777 r3294 20 20 USE geo2ocean ! for vector rotation on to model grid 21 21 USE lib_mpp ! MPP library 22 USE wrk_nemo ! work arrays 22 23 USE ioipsl, ONLY : ymds2ju, ju2ymds ! for calendar 23 24 24 25 IMPLICIT NONE 25 26 PRIVATE 27 28 PUBLIC fld_map ! routine called by tides_init 26 29 27 30 TYPE, PUBLIC :: FLD_N !: Namelist field informations … … 56 59 LOGICAL :: rotn ! flag to indicate whether field has been rotated 57 60 END TYPE FLD 61 62 TYPE, PUBLIC :: MAP_POINTER !: Array of integer pointers to 1D arrays 63 INTEGER, POINTER :: ptr(:) 64 END TYPE MAP_POINTER 58 65 59 66 !$AGRIF_DO_NOT_TREAT … … 98 105 CONTAINS 99 106 100 SUBROUTINE fld_read( kt, kn_fsbc, sd )107 SUBROUTINE fld_read( kt, kn_fsbc, sd, map, jit, time_offset ) 101 108 !!--------------------------------------------------------------------- 102 109 !! *** ROUTINE fld_read *** … … 113 120 INTEGER , INTENT(in ) :: kn_fsbc ! sbc computation period (in time step) 114 121 TYPE(FLD), INTENT(inout), DIMENSION(:) :: sd ! input field related variables 122 TYPE(MAP_POINTER),INTENT(in), OPTIONAL, DIMENSION(:) :: map ! global-to-local mapping index 123 INTEGER , INTENT(in ), OPTIONAL :: jit ! subcycle timestep for timesplitting option 124 INTEGER , INTENT(in ), OPTIONAL :: time_offset ! provide fields at time other than "now" 125 ! time_offset = -1 => fields at "before" time level 126 ! time_offset = +1 => fields at "after" time levels 127 ! etc. 115 128 !! 116 129 INTEGER :: imf ! size of the structure sd … … 119 132 INTEGER :: isecend ! number of second since Jan. 1st 00h of nit000 year at nitend 120 133 INTEGER :: isecsbc ! number of seconds between Jan. 1st 00h of nit000 year and the middle of sbc time step 134 INTEGER :: itime_add ! local time offset variable 121 135 LOGICAL :: llnxtyr ! open next year file? 122 136 LOGICAL :: llnxtmth ! open next month file? 123 137 LOGICAL :: llstop ! stop is the file does not exist 138 LOGICAL :: ll_firstcall ! true if this is the first call to fld_read for this set of fields 124 139 REAL(wp) :: ztinta ! ratio applied to after records when doing time interpolation 125 140 REAL(wp) :: ztintb ! ratio applied to before records when doing time interpolation 126 141 CHARACTER(LEN=1000) :: clfmt ! write format 127 142 !!--------------------------------------------------------------------- 143 ll_firstcall = .false. 144 IF( PRESENT(jit) ) THEN 145 IF(kt == nit000 .and. jit == 1) ll_firstcall = .true. 146 ELSE 147 IF(kt == nit000) ll_firstcall = .true. 148 ENDIF 149 150 itime_add = 0 151 IF( PRESENT(time_offset) ) itime_add = time_offset 152 128 153 ! Note that shifting time to be centrered in the middle of sbc time step impacts only nsec_* variables of the calendar 129 isecsbc = nsec_year + nsec1jan000 + NINT(0.5 * REAL(kn_fsbc - 1,wp) * rdttra(1)) ! middle of sbc time step 154 IF( present(jit) ) THEN 155 ! ignore kn_fsbc in this case 156 isecsbc = nsec_year + nsec1jan000 + (jit+itime_add)*rdt/REAL(nn_baro,wp) 157 ELSE 158 isecsbc = nsec_year + nsec1jan000 + NINT(0.5 * REAL(kn_fsbc - 1,wp) * rdttra(1)) + itime_add * rdttra(1) ! middle of sbc time step 159 ENDIF 130 160 imf = SIZE( sd ) 131 161 ! 132 IF( kt == nit000 ) THEN ! initialization 133 DO jf = 1, imf 134 CALL fld_init( kn_fsbc, sd(jf) ) ! read each before field (put them in after as they will be swapped) 135 END DO 162 IF( ll_firstcall ) THEN ! initialization 163 IF( PRESENT(map) ) THEN 164 DO jf = 1, imf 165 CALL fld_init( kn_fsbc, sd(jf), map(jf)%ptr ) ! read each before field (put them in after as they will be swapped) 166 END DO 167 ELSE 168 DO jf = 1, imf 169 CALL fld_init( kn_fsbc, sd(jf) ) ! read each before field (put them in after as they will be swapped) 170 END DO 171 ENDIF 136 172 IF( lwp ) CALL wgt_print() ! control print 137 173 CALL fld_rot( kt, sd ) ! rotate vector fiels if needed … … 143 179 DO jf = 1, imf ! --- loop over field --- ! 144 180 145 IF( isecsbc > sd(jf)%nrec_a(2) .OR. kt == nit000) THEN ! read/update the after data?181 IF( isecsbc > sd(jf)%nrec_a(2) .OR. ll_firstcall ) THEN ! read/update the after data? 146 182 147 183 IF( sd(jf)%ln_tint ) THEN ! swap before record field and informations … … 151 187 ENDIF 152 188 153 CALL fld_rec( kn_fsbc, sd(jf) ) ! update record informations 189 IF( PRESENT(jit) ) THEN 190 CALL fld_rec( kn_fsbc, sd(jf), time_offset=itime_add, jit=jit ) ! update record informations 191 ELSE 192 CALL fld_rec( kn_fsbc, sd(jf), time_offset=itime_add ) ! update record informations 193 ENDIF 154 194 155 195 ! do we have to change the year/month/week/day of the forcing field?? … … 212 252 213 253 ! read after data 214 CALL fld_get( sd(jf) ) 254 IF( PRESENT(map) ) THEN 255 CALL fld_get( sd(jf), map(jf)%ptr ) 256 ELSE 257 CALL fld_get( sd(jf) ) 258 ENDIF 215 259 216 260 ENDIF … … 225 269 clfmt = "('fld_read: var ', a, ' kt = ', i8, ' (', f7.2,' days), Y/M/D = ', i4.4,'/', i2.2,'/', i2.2," // & 226 270 & "', records b/a: ', i4.4, '/', i4.4, ' (days ', f7.2,'/', f7.2, ')')" 227 WRITE(numout, clfmt) TRIM( sd(jf)%clvar ), kt, REAL(isecsbc,wp)/rday, nyear, nmonth, nday, & 271 WRITE(numout, clfmt) TRIM( sd(jf)%clvar ), kt, REAL(isecsbc,wp)/rday, nyear, nmonth, nday, & 228 272 & sd(jf)%nrec_b(1), sd(jf)%nrec_a(1), REAL(sd(jf)%nrec_b(2),wp)/rday, REAL(sd(jf)%nrec_a(2),wp)/rday 273 WRITE(numout, *) 'itime_add is : ',itime_add 229 274 ENDIF 230 275 ! temporal interpolation weights … … 253 298 254 299 255 SUBROUTINE fld_init( kn_fsbc, sdjf )300 SUBROUTINE fld_init( kn_fsbc, sdjf, map ) 256 301 !!--------------------------------------------------------------------- 257 302 !! *** ROUTINE fld_init *** … … 262 307 INTEGER , INTENT(in ) :: kn_fsbc ! sbc computation period (in time step) 263 308 TYPE(FLD), INTENT(inout) :: sdjf ! input field related variables 309 INTEGER , INTENT(in), OPTIONAL, DIMENSION(:) :: map ! global-to-local mapping indices 264 310 !! 265 311 LOGICAL :: llprevyr ! are we reading previous year file? … … 364 410 365 411 ! read before data 366 CALL fld_get( sdjf ) ! read before values in after arrays(as we will swap it later) 412 IF( PRESENT(map) ) THEN 413 CALL fld_get( sdjf, map ) ! read before values in after arrays(as we will swap it later) 414 ELSE 415 CALL fld_get( sdjf ) ! read before values in after arrays(as we will swap it later) 416 ENDIF 367 417 368 418 clfmt = "('fld_init : time-interpolation for ', a, ' read previous record = ', i4, ' at time = ', f7.2, ' days')" … … 396 446 397 447 398 SUBROUTINE fld_rec( kn_fsbc, sdjf, ldbefore )448 SUBROUTINE fld_rec( kn_fsbc, sdjf, ldbefore, jit, time_offset ) 399 449 !!--------------------------------------------------------------------- 400 450 !! *** ROUTINE fld_rec *** … … 410 460 TYPE(FLD), INTENT(inout) :: sdjf ! input field related variables 411 461 LOGICAL , INTENT(in ), OPTIONAL :: ldbefore ! sent back before record values (default = .FALSE.) 462 INTEGER , INTENT(in ), OPTIONAL :: jit ! index of barotropic subcycle 412 463 ! used only if sdjf%ln_tint = .TRUE. 464 INTEGER , INTENT(in ), OPTIONAL :: time_offset ! Offset of required time level compared to "now" 465 ! time level in units of time steps. 413 466 !! 414 467 LOGICAL :: llbefore ! local definition of ldbefore … … 417 470 INTEGER :: ifreq_sec ! frequency mean (in seconds) 418 471 INTEGER :: isec_week ! number of seconds since the start of the weekly file 472 INTEGER :: itime_add ! local time offset variable 419 473 REAL(wp) :: ztmp ! temporary variable 420 474 !!---------------------------------------------------------------------- … … 425 479 ELSE ; llbefore = .FALSE. 426 480 ENDIF 481 ! 482 itime_add = 0 483 IF( PRESENT(time_offset) ) itime_add = time_offset 427 484 ! 428 485 ! ! =========== ! … … 443 500 ! 444 501 ztmp = REAL( nday, wp ) / REAL( nyear_len(1), wp ) + 0.5 502 IF( PRESENT(jit) ) THEN 503 ztmp = ztmp + (jit+itime_add)*rdt/REAL(nn_baro,wp) 504 ELSE 505 ztmp = ztmp + itime_add*rdttra(1) 506 ENDIF 445 507 sdjf%nrec_a(1) = 1 + INT( ztmp ) - COUNT((/llbefore/)) 446 508 ! swap at the middle of the year … … 471 533 ! 472 534 ztmp = REAL( nday, wp ) / REAL( nmonth_len(nmonth), wp ) + 0.5 535 IF( PRESENT(jit) ) THEN 536 ztmp = ztmp + (jit+itime_add)*rdt/REAL(nn_baro,wp) 537 ELSE 538 ztmp = ztmp + itime_add*rdttra(1) 539 ENDIF 473 540 imth = nmonth + INT( ztmp ) - COUNT((/llbefore/)) 474 541 IF( sdjf%cltype == 'monthly' ) THEN ; sdjf%nrec_a(1) = 1 + INT( ztmp ) - COUNT((/llbefore/)) … … 498 565 ztmp = ztmp + 0.5 * REAL(kn_fsbc - 1, wp) * rdttra(1) ! shift time to be centrered in the middle of sbc time step 499 566 ztmp = ztmp + 0.01 * rdttra(1) ! add 0.01 time step to avoid truncation error 567 IF( PRESENT(jit) ) THEN 568 ztmp = ztmp + (jit+itime_add)*rdt/REAL(nn_baro,wp) 569 ELSE 570 ztmp = ztmp + itime_add*rdttra(1) 571 ENDIF 500 572 IF( sdjf%ln_tint ) THEN ! time interpolation, shift by 1/2 record 501 573 ! … … 546 618 547 619 548 SUBROUTINE fld_get( sdjf )549 !!--------------------------------------------------------------------- 550 !! *** ROUTINE fld_ clopn***620 SUBROUTINE fld_get( sdjf, map ) 621 !!--------------------------------------------------------------------- 622 !! *** ROUTINE fld_get *** 551 623 !! 552 624 !! ** Purpose : read the data 553 625 !!---------------------------------------------------------------------- 554 626 TYPE(FLD), INTENT(inout) :: sdjf ! input field related variables 627 INTEGER , INTENT(in), OPTIONAL, DIMENSION(:) :: map ! global-to-local mapping indices 555 628 !! 556 629 INTEGER :: ipk ! number of vertical levels of sdjf%fdta ( 2D: ipk=1 ; 3D: ipk=jpk ) … … 559 632 560 633 ipk = SIZE( sdjf%fnow, 3 ) 561 IF( LEN(TRIM(sdjf%wgtname)) > 0 ) THEN 634 635 IF( PRESENT(map) ) THEN 636 IF( sdjf%ln_tint ) THEN ; CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fdta(:,:,:,2), sdjf%nrec_a(1), map ) 637 ELSE ; CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fnow(:,:,: ), sdjf%nrec_a(1), map ) 638 ENDIF 639 ELSE IF( LEN(TRIM(sdjf%wgtname)) > 0 ) THEN 562 640 CALL wgt_list( sdjf, iw ) 563 641 IF( sdjf%ln_tint ) THEN ; CALL fld_interp( sdjf%num, sdjf%clvar, iw , ipk , sdjf%fdta(:,:,:,2), sdjf%nrec_a(1) ) … … 581 659 END SUBROUTINE fld_get 582 660 661 SUBROUTINE fld_map( num, clvar, dta, nrec, map ) 662 !!--------------------------------------------------------------------- 663 !! *** ROUTINE fld_get *** 664 !! 665 !! ** Purpose : read global data from file and map onto local data 666 !! using a general mapping (for open boundaries) 667 !!---------------------------------------------------------------------- 668 #if defined key_bdy 669 USE bdy_oce, ONLY: dta_global ! workspace to read in global data arrays 670 #endif 671 672 INTEGER , INTENT(in ) :: num ! stream number 673 CHARACTER(LEN=*) , INTENT(in ) :: clvar ! variable name 674 REAL(wp), DIMENSION(:,:,:), INTENT(out) :: dta ! output field on model grid (2 dimensional) 675 INTEGER , INTENT(in ) :: nrec ! record number to read (ie time slice) 676 INTEGER, DIMENSION(:) , INTENT(in ) :: map ! global-to-local mapping indices 677 !! 678 INTEGER :: ipi ! length of boundary data on local process 679 INTEGER :: ipj ! length of dummy dimension ( = 1 ) 680 INTEGER :: ipk ! number of vertical levels of dta ( 2D: ipk=1 ; 3D: ipk=jpk ) 681 INTEGER :: ilendta ! length of data in file 682 INTEGER :: idvar ! variable ID 683 INTEGER :: ib, ik ! loop counters 684 INTEGER :: ierr 685 REAL(wp), POINTER, DIMENSION(:,:,:) :: dta_read ! work space for global data 686 !!--------------------------------------------------------------------- 687 688 #if defined key_bdy 689 dta_read => dta_global 690 #endif 691 692 ipi = SIZE( dta, 1 ) 693 ipj = 1 694 ipk = SIZE( dta, 3 ) 695 696 idvar = iom_varid( num, clvar ) 697 ilendta = iom_file(num)%dimsz(1,idvar) 698 IF(lwp) WRITE(numout,*) 'Dim size for ',TRIM(clvar),' is ', ilendta 699 IF(lwp) WRITE(numout,*) 'Number of levels for ',TRIM(clvar),' is ', ipk 700 701 SELECT CASE( ipk ) 702 CASE(1) 703 CALL iom_get ( num, jpdom_unknown, clvar, dta_read(1:ilendta,1:ipj,1 ), nrec ) 704 CASE DEFAULT 705 CALL iom_get ( num, jpdom_unknown, clvar, dta_read(1:ilendta,1:ipj,1:ipk), nrec ) 706 END SELECT 707 ! 708 DO ib = 1, ipi 709 DO ik = 1, ipk 710 dta(ib,1,ik) = dta_read(map(ib),1,ik) 711 END DO 712 END DO 713 714 END SUBROUTINE fld_map 715 583 716 584 717 SUBROUTINE fld_rot( kt, sd ) 585 718 !!--------------------------------------------------------------------- 586 !! *** ROUTINE fld_ clopn***719 !! *** ROUTINE fld_rot *** 587 720 !! 588 721 !! ** Purpose : Vector fields may need to be rotated onto the local grid direction 589 722 !!---------------------------------------------------------------------- 590 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released591 USE wrk_nemo, ONLY: utmp => wrk_2d_4, vtmp => wrk_2d_5 ! 2D workspace592 !!593 723 INTEGER , INTENT(in ) :: kt ! ocean time step 594 724 TYPE(FLD), INTENT(inout), DIMENSION(:) :: sd ! input field related variables 595 725 !! 596 INTEGER :: ju, jv, jk ! loop indices 597 INTEGER :: imf ! size of the structure sd 598 INTEGER :: ill ! character length 599 INTEGER :: iv ! indice of V component 600 CHARACTER (LEN=100) :: clcomp ! dummy weight name 601 !!--------------------------------------------------------------------- 602 603 IF(wrk_in_use(2, 4,5) ) THEN 604 CALL ctl_stop('fld_rot: ERROR: requested workspace arrays are unavailable.') ; RETURN 605 END IF 726 INTEGER :: ju, jv, jk ! loop indices 727 INTEGER :: imf ! size of the structure sd 728 INTEGER :: ill ! character length 729 INTEGER :: iv ! indice of V component 730 REAL(wp), POINTER, DIMENSION(:,:) :: utmp, vtmp ! temporary arrays for vector rotation 731 CHARACTER (LEN=100) :: clcomp ! dummy weight name 732 !!--------------------------------------------------------------------- 733 734 CALL wrk_alloc( jpi,jpj, utmp, vtmp ) 606 735 607 736 !! (sga: following code should be modified so that pairs arent searched for each time … … 638 767 END DO 639 768 ! 640 IF(wrk_not_released(2, 4,5) ) CALL ctl_stop('fld_rot: ERROR: failed to release workspace arrays.')769 CALL wrk_dealloc( jpi,jpj, utmp, vtmp ) 641 770 ! 642 771 END SUBROUTINE fld_rot … … 672 801 ! 673 802 CALL iom_open( sdjf%clname, sdjf%num, ldstop = ldstop, ldiof = LEN(TRIM(sdjf%wgtname)) > 0 ) 674 803 ! 675 804 END SUBROUTINE fld_clopn 676 805 … … 805 934 !! file, restructuring as required 806 935 !!---------------------------------------------------------------------- 807 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released, iwrk_in_use, iwrk_not_released808 USE wrk_nemo, ONLY: data_tmp => wrk_2d_1 ! 2D real workspace809 USE wrk_nemo, ONLY: data_src => iwrk_2d_1 ! 2D integer workspace810 !!811 936 TYPE( FLD ), INTENT(in) :: sd ! field with name of weights file 812 937 !! 813 INTEGER :: jn ! dummy loop indices 814 INTEGER :: inum ! temporary logical unit 815 INTEGER :: id ! temporary variable id 816 INTEGER :: ipk ! temporary vertical dimension 817 CHARACTER (len=5) :: aname 818 INTEGER , DIMENSION(3) :: ddims 819 LOGICAL :: cyclical 820 INTEGER :: zwrap ! local integer 821 !!---------------------------------------------------------------------- 822 ! 823 IF( wrk_in_use(2, 1) .OR. iwrk_in_use(2,1) ) THEN 824 CALL ctl_stop('fld_weight: requested workspace arrays are unavailable') ; RETURN 825 ENDIF 938 INTEGER :: jn ! dummy loop indices 939 INTEGER :: inum ! temporary logical unit 940 INTEGER :: id ! temporary variable id 941 INTEGER :: ipk ! temporary vertical dimension 942 CHARACTER (len=5) :: aname 943 INTEGER , DIMENSION(3) :: ddims 944 INTEGER , POINTER, DIMENSION(:,:) :: data_src 945 REAL(wp), POINTER, DIMENSION(:,:) :: data_tmp 946 LOGICAL :: cyclical 947 INTEGER :: zwrap ! local integer 948 !!---------------------------------------------------------------------- 949 ! 950 CALL wrk_alloc( jpi,jpj, data_src ) ! integer 951 CALL wrk_alloc( jpi,jpj, data_tmp ) 826 952 ! 827 953 IF( nxt_wgt > tot_wgts ) THEN … … 935 1061 ENDIF 936 1062 937 IF( wrk_not_released(2, 1) .OR. &938 iwrk_not_released(2, 1) ) CALL ctl_stop('fld_weight: failed to release workspace arrays')1063 CALL wrk_dealloc( jpi,jpj, data_src ) ! integer 1064 CALL wrk_dealloc( jpi,jpj, data_tmp ) 939 1065 ! 940 1066 END SUBROUTINE fld_weight -
trunk/NEMOGCM/NEMO/OPA_SRC/SBC/sbc_ice.F90
r2777 r3294 6 6 !! History : 3.0 ! 2006-08 (G. Madec) Surface module 7 7 !! 3.2 ! 2009-06 (S. Masson) merge with ice_oce 8 !! 4.0 ! 2011-01 (A. R. Porter, STFC Daresbury) dynamical allocation 8 !! 3.3.1! 2011-01 (A. R. Porter, STFC Daresbury) dynamical allocation 9 !! 3.4 ! 2011-11 (C. Harris) CICE added as an option 9 10 !!---------------------------------------------------------------------- 10 #if defined key_lim3 || defined key_lim2 11 #if defined key_lim3 || defined key_lim2 || defined key_cice 11 12 !!---------------------------------------------------------------------- 12 13 !! 'key_lim2' or 'key_lim3' : LIM-2 or LIM-3 sea-ice model … … 19 20 USE par_ice_2 ! LIM-2 parameters 20 21 # endif 22 # if defined key_cice 23 USE ice_domain_size, only: ncat 24 #endif 21 25 USE lib_mpp ! MPP library 22 26 USE in_out_manager ! I/O manager … … 30 34 LOGICAL , PUBLIC, PARAMETER :: lk_lim2 = .TRUE. !: LIM-2 ice model 31 35 LOGICAL , PUBLIC, PARAMETER :: lk_lim3 = .FALSE. !: no LIM-3 36 LOGICAL , PUBLIC, PARAMETER :: lk_cice = .FALSE. !: no CICE 32 37 # if defined key_lim2_vp 33 38 CHARACTER(len=1), PUBLIC, PARAMETER :: cp_ice_msh = 'I' !: VP : 'I'-grid ice-velocity (B-grid lower left corner) … … 39 44 LOGICAL , PUBLIC, PARAMETER :: lk_lim2 = .FALSE. !: no LIM-2 40 45 LOGICAL , PUBLIC, PARAMETER :: lk_lim3 = .TRUE. !: LIM-3 ice model 46 LOGICAL , PUBLIC, PARAMETER :: lk_cice = .FALSE. !: no CICE 41 47 CHARACTER(len=1), PUBLIC, PARAMETER :: cp_ice_msh = 'C' !: 'C'-grid ice-velocity 42 48 # endif 49 # if defined key_cice 50 LOGICAL , PUBLIC, PARAMETER :: lk_lim2 = .FALSE. !: no LIM-2 51 LOGICAL , PUBLIC, PARAMETER :: lk_lim3 = .FALSE. !: no LIM-3 52 LOGICAL , PUBLIC, PARAMETER :: lk_cice = .TRUE. !: CICE ice model 53 CHARACTER(len=1), PUBLIC :: cp_ice_msh = 'F' !: 'F'-grid ice-velocity 54 # endif 43 55 56 #if defined key_lim3 || defined key_lim2 44 57 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qns_ice !: non solar heat flux over ice [W/m2] 45 58 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qsr_ice !: solar heat flux over ice [W/m2] … … 60 73 # endif 61 74 75 #elif defined key_cice 76 ! 77 ! for consistency with LIM, these are declared with three dimensions 78 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qlw_ice !: incoming long-wave 79 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qla_ice !: latent flux over ice [W/m2] 80 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qsr_ice !: solar heat flux over ice [W/m2] 81 ! 82 ! other forcing arrays are two dimensional 83 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ss_iou !: x ice-ocean surface stress at NEMO U point 84 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ss_iov !: y ice-ocean surface stress at NEMO V point 85 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp_ice !: sublimation-snow budget over ice [kg/m2] 86 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tatm_ice !: air temperature 87 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qatm_ice !: specific humidity 88 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wndi_ice !: i wind at T point 89 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wndj_ice !: j wind at T point 90 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: nfrzmlt !: NEMO frzmlt 91 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fr_iu !: ice fraction at NEMO U point 92 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fr_iv !: ice fraction at NEMO V point 93 ! 94 ! finally, arrays corresponding to different ice categories 95 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_i !: category ice fraction 96 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: topmelt !: category topmelt 97 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: botmelt !: category botmelt 98 #endif 99 62 100 !!---------------------------------------------------------------------- 63 101 !! NEMO/OPA 4.0 , NEMO Consortium (2011) … … 71 109 !! *** FUNCTION sbc_ice_alloc *** 72 110 !!---------------------------------------------------------------------- 111 #if defined key_lim3 || defined key_lim2 73 112 ALLOCATE( qns_ice (jpi,jpj,jpl) , qsr_ice (jpi,jpj,jpl) , & 74 113 & qla_ice (jpi,jpj,jpl) , dqla_ice(jpi,jpj,jpl) , & … … 77 116 & utau_ice(jpi,jpj) , vtau_ice(jpi,jpj) , & 78 117 & fr1_i0 (jpi,jpj) , fr2_i0 (jpi,jpj) , & 79 # 118 #if defined key_lim3 80 119 & emp_ice(jpi,jpj) , tatm_ice(jpi,jpj) , STAT= sbc_ice_alloc ) 81 # 120 #else 82 121 & emp_ice(jpi,jpj) , STAT= sbc_ice_alloc ) 83 # endif 122 #endif 123 #elif defined key_cice 124 ALLOCATE( qla_ice(jpi,jpj,1) , qlw_ice(jpi,jpj,1) , qsr_ice(jpi,jpj,1) , & 125 wndi_ice(jpi,jpj) , tatm_ice(jpi,jpj) , qatm_ice(jpi,jpj) , & 126 wndj_ice(jpi,jpj) , nfrzmlt(jpi,jpj) , ss_iou(jpi,jpj) , & 127 ss_iov(jpi,jpj) , fr_iu(jpi,jpj) , fr_iv(jpi,jpj) , & 128 a_i(jpi,jpj,ncat) , topmelt(jpi,jpj,ncat) , botmelt(jpi,jpj,ncat), STAT= sbc_ice_alloc ) 129 #endif 84 130 ! 85 131 IF( lk_mpp ) CALL mpp_sum ( sbc_ice_alloc ) … … 89 135 #else 90 136 !!---------------------------------------------------------------------- 91 !! Default option NO LIM 2.0 or 3.0 sea-ice model137 !! Default option NO LIM 2.0 or 3.0 or CICE sea-ice model 92 138 !!---------------------------------------------------------------------- 93 139 LOGICAL , PUBLIC, PARAMETER :: lk_lim2 = .FALSE. !: no LIM-2 ice model 94 140 LOGICAL , PUBLIC, PARAMETER :: lk_lim3 = .FALSE. !: no LIM-3 ice model 141 LOGICAL , PUBLIC, PARAMETER :: lk_cice = .FALSE. !: no CICE ice model 95 142 CHARACTER(len=1), PUBLIC, PARAMETER :: cp_ice_msh = '-' !: no grid ice-velocity 96 143 #endif -
trunk/NEMOGCM/NEMO/OPA_SRC/SBC/sbc_oce.F90
r2715 r3294 33 33 LOGICAL , PUBLIC :: ln_blk_clio = .FALSE. !: CLIO bulk formulation 34 34 LOGICAL , PUBLIC :: ln_blk_core = .FALSE. !: CORE bulk formulation 35 LOGICAL , PUBLIC :: ln_blk_mfs = .FALSE. !: MFS bulk formulation 35 36 LOGICAL , PUBLIC :: ln_cpl = .FALSE. !: coupled formulation (overwritten by key_sbc_coupled ) 36 37 LOGICAL , PUBLIC :: ln_dm2dc = .FALSE. !: Daily mean to Diurnal Cycle short wave (qsr) … … 43 44 ! !: = 1 global mean of e-p-r set to zero at each nn_fsbc time step 44 45 ! !: = 2 annual global mean of e-p-r set to zero 46 LOGICAL , PUBLIC :: ln_cdgw = .FALSE. !: true if neutral drag coefficient read from wave model 45 47 46 48 !!---------------------------------------------------------------------- -
trunk/NEMOGCM/NEMO/OPA_SRC/SBC/sbcana.F90
r2715 r3294 89 89 nn_tau000 = MAX( nn_tau000, 1 ) ! must be >= 1 90 90 ! 91 qns (:,:) = rn_qns0 92 qsr (:,:) = rn_qsr0 93 emp (:,:) = rn_emp0 94 emps(:,:) = rn_emp0 95 ! 96 utau(:,:) = rn_utau0 97 vtau(:,:) = rn_vtau0 98 taum(:,:) = SQRT ( rn_utau0 * rn_utau0 + rn_vtau0 * rn_vtau0 ) 99 wndm(:,:) = SQRT ( taum(1,1) / ( zrhoa * zcdrag ) ) 100 ! 91 101 ENDIF 92 102 93 qns (:,:) = rn_qns094 qsr (:,:) = rn_qsr095 emp (:,:) = rn_emp096 emps(:,:) = rn_emp097 103 98 104 ! Increase the surface stress to its nominal value during the first nn_tau000 time-steps … … 193 199 ! 23.5 deg : tropics 194 200 qsr (ji,jj) = 230 * COS( 3.1415 * ( gphit(ji,jj) - 23.5 * zcos_sais1 ) / ( 0.9 * 180 ) ) 195 qns (ji,jj) = ztrp * ( t b(ji,jj,1) - t_star ) - qsr(ji,jj)201 qns (ji,jj) = ztrp * ( tsb(ji,jj,1,jp_tem) - t_star ) - qsr(ji,jj) 196 202 IF( gphit(ji,jj) >= 14.845 .AND. 37.2 >= gphit(ji,jj) ) THEN ! zero at 37.8 deg, max at 24.6 deg 197 203 emp (ji,jj) = zemp_S * zconv & -
trunk/NEMOGCM/NEMO/OPA_SRC/SBC/sbcapr.F90
r2715 r3294 10 10 !! sbc_apr : read atmospheric pressure in netcdf files 11 11 !!---------------------------------------------------------------------- 12 USE bdy_par ! Unstructured boundary parameters13 12 USE obc_par ! open boundary condition parameters 14 13 USE dom_oce ! ocean space and time domain … … 30 29 ! !!* namsbc_apr namelist (Atmospheric PRessure) * 31 30 LOGICAL, PUBLIC :: ln_apr_obc = .FALSE. !: inverse barometer added to OBC ssh data 32 LOGICAL, PUBLIC :: ln_apr_bdy = .FALSE. !: inverse barometer added to BDY ssh data33 31 LOGICAL, PUBLIC :: ln_ref_apr = .FALSE. !: ref. pressure: global mean Patm (F) or a constant (F) 34 32 … … 115 113 ! 116 114 ! !* control check 117 IF( ln_apr_obc .OR. ln_apr_bdy) &118 CALL ctl_stop( 'sbc_apr: inverse barometer added to OBC or BDYssh data not yet implemented ' )115 IF( ln_apr_obc ) & 116 CALL ctl_stop( 'sbc_apr: inverse barometer added to OBC ssh data not yet implemented ' ) 119 117 IF( ln_apr_obc .AND. .NOT. lk_obc ) & 120 118 CALL ctl_stop( 'sbc_apr: add inverse barometer to OBC requires to use key_obc' ) 121 IF( ln_apr_bdy .AND. .NOT. lk_bdy ) & 122 CALL ctl_stop( 'sbc_apr: add inverse barometer to OBC requires to use key_bdy' ) 123 IF( ( ln_apr_obc .OR. ln_apr_bdy ) .AND. .NOT. lk_dynspg_ts ) & 119 IF( ( ln_apr_obc ) .AND. .NOT. lk_dynspg_ts ) & 124 120 CALL ctl_stop( 'sbc_apr: use inverse barometer ssh at open boundary ONLY possible with time-splitting' ) 125 IF( ( ln_apr_obc .OR. ln_apr_bdy) .AND. .NOT. ln_apr_dyn ) &121 IF( ( ln_apr_obc ) .AND. .NOT. ln_apr_dyn ) & 126 122 CALL ctl_stop( 'sbc_apr: use inverse barometer ssh at open boundary ONLY requires ln_apr_dyn=T' ) 127 123 ENDIF -
trunk/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_clio.F90
r2777 r3294 27 27 USE in_out_manager ! I/O manager 28 28 USE lib_mpp ! distribued memory computing library 29 USE wrk_nemo ! work arrays 30 USE timing ! Timing 29 31 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 30 32 … … 207 209 !! ** Nota : sf has to be a dummy argument for AGRIF on NEC 208 210 !!---------------------------------------------------------------------- 209 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released210 USE wrk_nemo, ONLY: zqlw => wrk_2d_1 ! long-wave heat flux over ocean211 USE wrk_nemo, ONLY: zqla => wrk_2d_2 ! latent heat flux over ocean212 USE wrk_nemo, ONLY: zqsb => wrk_2d_3 ! sensible heat flux over ocean213 !!214 211 TYPE(fld), INTENT(in), DIMENSION(:) :: sf ! input data 215 212 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pst ! surface temperature [Celcius] … … 227 224 REAL(wp) :: zrhoa, zev, zes, zeso, zqatm, zevsqr ! - - 228 225 REAL(wp) :: ztx2, zty2 ! - - 226 REAL(wp), POINTER, DIMENSION(:,:) :: zqlw ! long-wave heat flux over ocean 227 REAL(wp), POINTER, DIMENSION(:,:) :: zqla ! latent heat flux over ocean 228 REAL(wp), POINTER, DIMENSION(:,:) :: zqsb ! sensible heat flux over ocean 229 229 !!--------------------------------------------------------------------- 230 231 IF( wrk_in_use(3, 1,2,3) ) THEN232 CALL ctl_stop('blk_oce_clio: requested workspace arrays are unavailable') ; RETURN233 ENDIF230 ! 231 IF( nn_timing == 1 ) CALL timing_start('blk_oce_clio') 232 ! 233 CALL wrk_alloc( jpi,jpj, zqlw, zqla, zqsb ) 234 234 235 235 zpatm = 101000._wp ! atmospheric pressure (assumed constant here) … … 382 382 ENDIF 383 383 384 IF( wrk_not_released(3, 1,2,3) ) CALL ctl_stop('blk_oce_clio: failed to release workspace arrays') 384 CALL wrk_dealloc( jpi,jpj, zqlw, zqla, zqsb ) 385 ! 386 IF( nn_timing == 1 ) CALL timing_stop('blk_oce_clio') 385 387 ! 386 388 END SUBROUTINE blk_oce_clio … … 414 416 !! 415 417 !!---------------------------------------------------------------------- 416 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released417 USE wrk_nemo, ONLY: ztatm => wrk_2d_1 ! Tair in Kelvin418 USE wrk_nemo, ONLY: zqatm => wrk_2d_2 ! specific humidity419 USE wrk_nemo, ONLY: zevsqr => wrk_2d_3 ! vapour pressure square-root420 USE wrk_nemo, ONLY: zrhoa => wrk_2d_4 ! air density421 USE wrk_nemo, ONLY: wrk_3d_1 , wrk_3d_2422 !!423 418 REAL(wp), INTENT(in ), DIMENSION(:,:,:) :: pst ! ice surface temperature [Kelvin] 424 419 REAL(wp), INTENT(in ), DIMENSION(:,:,:) :: palb_cs ! ice albedo (clear sky) (alb_ice_cs) [%] … … 448 443 REAL(wp) :: ztice3, zticemb, zticemb2, zdqlw, zdqsb ! - - 449 444 !! 445 REAL(wp), DIMENSION(:,:) , POINTER :: ztatm ! Tair in Kelvin 446 REAL(wp), DIMENSION(:,:) , POINTER :: zqatm ! specific humidity 447 REAL(wp), DIMENSION(:,:) , POINTER :: zevsqr ! vapour pressure square-root 448 REAL(wp), DIMENSION(:,:) , POINTER :: zrhoa ! air density 450 449 REAL(wp), DIMENSION(:,:,:), POINTER :: z_qlw, z_qsb 451 450 !!--------------------------------------------------------------------- 452 453 IF( wrk_in_use(2, 1,2,3,4) .OR. wrk_in_use(3, 1,2) ) THEN 454 CALL ctl_stop('blk_ice_clio: requested workspace arrays are unavailable') ; RETURN 455 ELSE IF(pdim > jpk)THEN 456 CALL ctl_stop('blk_ice_clio: too many ice levels to use wrk_nemo 3D workspaces.') 457 RETURN 458 END IF 459 z_qlw => wrk_3d_1(:,:,1:pdim) 460 z_qsb => wrk_3d_2(:,:,1:pdim) 451 ! 452 IF( nn_timing == 1 ) CALL timing_start('blk_ice_clio') 453 ! 454 CALL wrk_alloc( jpi,jpj, ztatm, zqatm, zevsqr, zrhoa ) 455 CALL wrk_alloc( jpi,jpj,pdim, z_qlw, z_qsb ) 461 456 462 457 ijpl = pdim ! number of ice categories … … 634 629 ENDIF 635 630 636 IF( wrk_not_released(2, 1,2,3,4) .OR. & 637 wrk_not_released(3, 1,2) ) CALL ctl_stop('blk_ice_clio: failed to release workspace arrays') 631 CALL wrk_dealloc( jpi,jpj, ztatm, zqatm, zevsqr, zrhoa ) 632 CALL wrk_dealloc( jpi,jpj,pdim, z_qlw, z_qsb ) 633 ! 634 IF( nn_timing == 1 ) CALL timing_stop('blk_ice_clio') 638 635 ! 639 636 END SUBROUTINE blk_ice_clio … … 650 647 !! - also initialise sbudyko and stauc once for all 651 648 !!---------------------------------------------------------------------- 652 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released653 USE wrk_nemo, ONLY: zev => wrk_2d_1 ! vapour pressure654 USE wrk_nemo, ONLY: zdlha => wrk_2d_2 , zlsrise => wrk_2d_3 , zlsset => wrk_2d_4655 USE wrk_nemo, ONLY: zps => wrk_2d_5 , zpc => wrk_2d_6 ! sin/cos of latitude per sin/cos of solar declination656 !!657 649 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: pqsr_oce ! shortwave radiation over the ocean 658 650 !! … … 673 665 REAL(wp) :: zxday, zdist, zcoef, zcoef1 ! 674 666 REAL(wp) :: zes 667 668 REAL(wp), DIMENSION(:,:), POINTER :: zev ! vapour pressure 669 REAL(wp), DIMENSION(:,:), POINTER :: zdlha, zlsrise, zlsset ! 2D workspace 670 REAL(wp), DIMENSION(:,:), POINTER :: zps, zpc ! sine (cosine) of latitude per sine (cosine) of solar declination 675 671 !!--------------------------------------------------------------------- 676 677 IF( wrk_in_use(2, 1,2,3,4,5,6) ) THEN678 CALL ctl_stop('blk_clio_qsr_oce: requested workspace arrays unavailable') ; RETURN679 END IF672 ! 673 IF( nn_timing == 1 ) CALL timing_start('blk_clio_qsr_oce') 674 ! 675 CALL wrk_alloc( jpi,jpj, zev, zdlha, zlsrise, zlsset, zps, zpc ) 680 676 681 677 IF( lbulk_init ) THEN ! Initilization at first time step only … … 791 787 END DO 792 788 793 IF( wrk_not_released(2, 1,2,3,4,5,6) ) CALL ctl_stop('blk_clio_qsr_oce: failed to release workspace arrays') 789 CALL wrk_dealloc( jpi,jpj, zev, zdlha, zlsrise, zlsset, zps, zpc ) 790 ! 791 IF( nn_timing == 1 ) CALL timing_stop('blk_clio_qsr_oce') 794 792 ! 795 793 END SUBROUTINE blk_clio_qsr_oce … … 806 804 !! - also initialise sbudyko and stauc once for all 807 805 !!---------------------------------------------------------------------- 808 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released809 USE wrk_nemo, ONLY: zev => wrk_2d_1 ! vapour pressure810 USE wrk_nemo, ONLY: zdlha => wrk_2d_2 ! 2D workspace811 USE wrk_nemo, ONLY: zlsrise => wrk_2d_3 ! 2D workspace812 USE wrk_nemo, ONLY: zlsset => wrk_2d_4 ! 2D workspace813 USE wrk_nemo, ONLY: zps => wrk_2d_5 , zpc => wrk_2d_6 ! sin/cos of latitude per sin/cos of solar declination814 !!815 806 REAL(wp), INTENT(in ), DIMENSION(:,:,:) :: pa_ice_cs ! albedo of ice under clear sky 816 807 REAL(wp), INTENT(in ), DIMENSION(:,:,:) :: pa_ice_os ! albedo of ice under overcast sky … … 830 821 REAL(wp) :: zxday, zdist, zcoef, zcoef1 ! - - 831 822 REAL(wp) :: zqsr_ice_cs, zqsr_ice_os ! - - 823 824 REAL(wp), DIMENSION(:,:), POINTER :: zev ! vapour pressure 825 REAL(wp), DIMENSION(:,:), POINTER :: zdlha, zlsrise, zlsset ! 2D workspace 826 REAL(wp), DIMENSION(:,:), POINTER :: zps, zpc ! sine (cosine) of latitude per sine (cosine) of solar declination 832 827 !!--------------------------------------------------------------------- 833 834 IF( wrk_in_use(2, 1,2,3,4,5,6) ) THEN835 CALL ctl_stop('blk_clio_qsr_ice: requested workspace arrays unavailable') ; RETURN836 ENDIF828 ! 829 IF( nn_timing == 1 ) CALL timing_start('blk_clio_qsr_ice') 830 ! 831 CALL wrk_alloc( jpi,jpj, zev, zdlha, zlsrise, zlsset, zps, zpc ) 837 832 838 833 ijpl = SIZE(pqsr_ice, 3 ) ! number of ice categories … … 937 932 END DO 938 933 ! 939 IF( wrk_not_released(2, 1,2,3,4,5,6) ) CALL ctl_stop('blk_clio_qsr_ice: failed to release workspace arrays') 934 CALL wrk_dealloc( jpi,jpj, zev, zdlha, zlsrise, zlsset, zps, zpc ) 935 ! 936 IF( nn_timing == 1 ) CALL timing_stop('blk_clio_qsr_ice') 940 937 ! 941 938 END SUBROUTINE blk_clio_qsr_ice -
trunk/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_core.F90
r2777 r3294 14 14 !! 3.2 ! 2009-04 (B. Lemaire) Introduce iom_put 15 15 !! 3.3 ! 2010-10 (S. Masson) add diurnal cycle 16 !! 3.4 ! 2011-11 (C. Harris) Fill arrays required by CICE 16 17 !!---------------------------------------------------------------------- 17 18 … … 32 33 USE in_out_manager ! I/O manager 33 34 USE lib_mpp ! distribued memory computing library 35 USE wrk_nemo ! work arrays 36 USE timing ! Timing 34 37 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 35 38 USE prtctl ! Print control 36 #if defined key_lim3 39 USE sbcwave,ONLY : cdn_wave !wave module 40 #if defined key_lim3 || defined key_cice 37 41 USE sbc_ice ! Surface boundary condition: ice fields 38 42 #endif … … 43 47 PUBLIC sbc_blk_core ! routine called in sbcmod module 44 48 PUBLIC blk_ice_core ! routine called in sbc_ice_lim module 49 PUBLIC turb_core_2z ! routine calles in sbcblk_mfs module 45 50 46 51 INTEGER , PARAMETER :: jpfld = 9 ! maximum number of files to read … … 182 187 ! ! surface ocean fluxes computed with CLIO bulk formulea 183 188 IF( MOD( kt - 1, nn_fsbc ) == 0 ) CALL blk_oce_core( sf, sst_m, ssu_m, ssv_m ) 189 190 #if defined key_cice 191 IF( MOD( kt - 1, nn_fsbc ) == 0 ) THEN 192 qlw_ice(:,:,1) = sf(jp_qlw)%fnow(:,:,1) 193 qsr_ice(:,:,1) = sf(jp_qsr)%fnow(:,:,1) 194 tatm_ice(:,:) = sf(jp_tair)%fnow(:,:,1) 195 qatm_ice(:,:) = sf(jp_humi)%fnow(:,:,1) 196 tprecip(:,:) = sf(jp_prec)%fnow(:,:,1) * rn_pfac 197 sprecip(:,:) = sf(jp_snow)%fnow(:,:,1) * rn_pfac 198 wndi_ice(:,:) = sf(jp_wndi)%fnow(:,:,1) 199 wndj_ice(:,:) = sf(jp_wndj)%fnow(:,:,1) 200 ENDIF 201 #endif 184 202 ! 185 203 END SUBROUTINE sbc_blk_core … … 207 225 !! ** Nota : sf has to be a dummy argument for AGRIF on NEC 208 226 !!--------------------------------------------------------------------- 209 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released210 USE wrk_nemo, ONLY: zwnd_i => wrk_2d_1 , zwnd_j => wrk_2d_2 ! wind speed components at T-point211 USE wrk_nemo, ONLY: zqsatw => wrk_2d_3 ! specific humidity at pst212 USE wrk_nemo, ONLY: zqlw => wrk_2d_4 , zqsb => wrk_2d_5 ! long wave and sensible heat fluxes213 USE wrk_nemo, ONLY: zqla => wrk_2d_6 , zevap => wrk_2d_7 ! latent heat fluxes and evaporation214 USE wrk_nemo, ONLY: Cd => wrk_2d_8 ! transfer coefficient for momentum (tau)215 USE wrk_nemo, ONLY: Ch => wrk_2d_9 ! transfer coefficient for sensible heat (Q_sens)216 USE wrk_nemo, ONLY: Ce => wrk_2d_10 ! transfer coefficient for evaporation (Q_lat)217 USE wrk_nemo, ONLY: zst => wrk_2d_11 ! surface temperature in Kelvin218 USE wrk_nemo, ONLY: zt_zu => wrk_2d_12 ! air temperature at wind speed height219 USE wrk_nemo, ONLY: zq_zu => wrk_2d_13 ! air spec. hum. at wind speed height220 !221 227 TYPE(fld), INTENT(in), DIMENSION(:) :: sf ! input data 222 228 REAL(wp) , INTENT(in), DIMENSION(:,:) :: pst ! surface temperature [Celcius] … … 226 232 INTEGER :: ji, jj ! dummy loop indices 227 233 REAL(wp) :: zcoef_qsatw, zztmp ! local variable 234 REAL(wp), DIMENSION(:,:), POINTER :: zwnd_i, zwnd_j ! wind speed components at T-point 235 REAL(wp), DIMENSION(:,:), POINTER :: zqsatw ! specific humidity at pst 236 REAL(wp), DIMENSION(:,:), POINTER :: zqlw, zqsb ! long wave and sensible heat fluxes 237 REAL(wp), DIMENSION(:,:), POINTER :: zqla, zevap ! latent heat fluxes and evaporation 238 REAL(wp), DIMENSION(:,:), POINTER :: Cd ! transfer coefficient for momentum (tau) 239 REAL(wp), DIMENSION(:,:), POINTER :: Ch ! transfer coefficient for sensible heat (Q_sens) 240 REAL(wp), DIMENSION(:,:), POINTER :: Ce ! tansfert coefficient for evaporation (Q_lat) 241 REAL(wp), DIMENSION(:,:), POINTER :: zst ! surface temperature in Kelvin 242 REAL(wp), DIMENSION(:,:), POINTER :: zt_zu ! air temperature at wind speed height 243 REAL(wp), DIMENSION(:,:), POINTER :: zq_zu ! air spec. hum. at wind speed height 228 244 !!--------------------------------------------------------------------- 229 230 IF( wrk_in_use(2, 1,2,3,4,5,6,7,8,9,10,11,12,13) ) THEN 231 CALL ctl_stop('blk_oce_core: requested workspace arrays unavailable') ; RETURN 232 ENDIF 245 ! 246 IF( nn_timing == 1 ) CALL timing_start('blk_oce_core') 247 ! 248 CALL wrk_alloc( jpi,jpj, zwnd_i, zwnd_j, zqsatw, zqlw, zqsb, zqla, zevap ) 249 CALL wrk_alloc( jpi,jpj, Cd, Ch, Ce, zst, zt_zu, zq_zu ) 233 250 ! 234 251 ! local scalars ( place there for vector optimisation purposes) … … 380 397 ENDIF 381 398 ! 382 IF( wrk_not_released(2, 1,2,3,4,5,6,7,8,9,10,11,12,13) ) & 383 CALL ctl_stop('blk_oce_core: failed to release workspace arrays') 399 CALL wrk_dealloc( jpi,jpj, zwnd_i, zwnd_j, zqsatw, zqlw, zqsb, zqla, zevap ) 400 CALL wrk_dealloc( jpi,jpj, Cd, Ch, Ce, zst, zt_zu, zq_zu ) 401 ! 402 IF( nn_timing == 1 ) CALL timing_stop('blk_oce_core') 384 403 ! 385 404 END SUBROUTINE blk_oce_core … … 403 422 !! caution : the net upward water flux has with mm/day unit 404 423 !!--------------------------------------------------------------------- 405 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released406 USE wrk_nemo, ONLY: z_wnds_t => wrk_2d_1 ! wind speed ( = | U10m - U_ice | ) at T-point407 USE wrk_nemo, ONLY: wrk_3d_4 , wrk_3d_5 , wrk_3d_6 , wrk_3d_7408 !!409 424 REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pst ! ice surface temperature (>0, =rt0 over land) [Kelvin] 410 425 REAL(wp), DIMENSION(:,:) , INTENT(in ) :: pui ! ice surface velocity (i- and i- components [m/s] … … 434 449 REAL(wp) :: zwndi_t , zwndj_t ! relative wind components at T-point 435 450 !! 451 REAL(wp), DIMENSION(:,:) , POINTER :: z_wnds_t ! wind speed ( = | U10m - U_ice | ) at T-point 436 452 REAL(wp), DIMENSION(:,:,:), POINTER :: z_qlw ! long wave heat flux over ice 437 453 REAL(wp), DIMENSION(:,:,:), POINTER :: z_qsb ! sensible heat flux over ice … … 439 455 REAL(wp), DIMENSION(:,:,:), POINTER :: z_dqsb ! sensible heat sensitivity over ice 440 456 !!--------------------------------------------------------------------- 457 ! 458 IF( nn_timing == 1 ) CALL timing_start('blk_ice_core') 459 ! 460 CALL wrk_alloc( jpi,jpj, z_wnds_t ) 461 CALL wrk_alloc( jpi,jpj,pdim, z_qlw, z_qsb, z_dqlw, z_dqsb ) 441 462 442 463 ijpl = pdim ! number of ice categories 443 444 ! Set-up access to workspace arrays445 IF( wrk_in_use(2, 1) .OR. wrk_in_use(3, 4,5,6,7) ) THEN446 CALL ctl_stop('blk_ice_core: requested workspace arrays unavailable') ; RETURN447 ELSE IF(ijpl > jpk) THEN448 CALL ctl_stop('blk_ice_core: no. of ice categories > jpk so wrk_nemo 3D workspaces cannot be used.')449 RETURN450 END IF451 ! Set-up pointers to sub-arrays of workspaces452 z_qlw => wrk_3d_4(:,:,1:ijpl)453 z_qsb => wrk_3d_5(:,:,1:ijpl)454 z_dqlw => wrk_3d_6(:,:,1:ijpl)455 z_dqsb => wrk_3d_7(:,:,1:ijpl)456 464 457 465 ! local scalars ( place there for vector optimisation purposes) … … 606 614 ENDIF 607 615 608 IF( wrk_not_released(2, 1) .OR. & 609 wrk_not_released(3, 4,5,6,7) ) CALL ctl_stop('blk_ice_core: failed to release workspace arrays') 616 CALL wrk_dealloc( jpi,jpj, z_wnds_t ) 617 CALL wrk_dealloc( jpi,jpj,pdim, z_qlw, z_qsb, z_dqlw, z_dqsb ) 618 ! 619 IF( nn_timing == 1 ) CALL timing_stop('blk_ice_core') 610 620 ! 611 621 END SUBROUTINE blk_ice_core … … 628 638 !! References : Large & Yeager, 2004 : ??? 629 639 !!---------------------------------------------------------------------- 630 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released, iwrk_in_use, iwrk_not_released631 USE wrk_nemo, ONLY: dU10 => wrk_2d_14 ! dU [m/s]632 USE wrk_nemo, ONLY: dT => wrk_2d_15 ! air/sea temperature difference [K]633 USE wrk_nemo, ONLY: dq => wrk_2d_16 ! air/sea humidity difference [K]634 USE wrk_nemo, ONLY: Cd_n10 => wrk_2d_17 ! 10m neutral drag coefficient635 USE wrk_nemo, ONLY: Ce_n10 => wrk_2d_18 ! 10m neutral latent coefficient636 USE wrk_nemo, ONLY: Ch_n10 => wrk_2d_19 ! 10m neutral sensible coefficient637 USE wrk_nemo, ONLY: sqrt_Cd_n10 => wrk_2d_20 ! root square of Cd_n10638 USE wrk_nemo, ONLY: sqrt_Cd => wrk_2d_21 ! root square of Cd639 USE wrk_nemo, ONLY: T_vpot => wrk_2d_22 ! virtual potential temperature [K]640 USE wrk_nemo, ONLY: T_star => wrk_2d_23 ! turbulent scale of tem. fluct.641 USE wrk_nemo, ONLY: q_star => wrk_2d_24 ! turbulent humidity of temp. fluct.642 USE wrk_nemo, ONLY: U_star => wrk_2d_25 ! turb. scale of velocity fluct.643 USE wrk_nemo, ONLY: L => wrk_2d_26 ! Monin-Obukov length [m]644 USE wrk_nemo, ONLY: zeta => wrk_2d_27 ! stability parameter at height zu645 USE wrk_nemo, ONLY: U_n10 => wrk_2d_28 ! neutral wind velocity at 10m [m]646 USE wrk_nemo, ONLY: xlogt => wrk_2d_29, xct => wrk_2d_30, &647 zpsi_h => wrk_2d_31, zpsi_m => wrk_2d_32648 USE wrk_nemo, ONLY: stab => iwrk_2d_1 ! 1st guess stability test integer649 !650 640 REAL(wp) , INTENT(in ) :: zu ! altitude of wind measurement [m] 651 641 REAL(wp), DIMENSION(:,:), INTENT(in ) :: sst ! sea surface temperature [Kelvin] … … 662 652 REAL(wp), PARAMETER :: grav = 9.8 ! gravity 663 653 REAL(wp), PARAMETER :: kappa = 0.4 ! von Karman s constant 654 655 REAL(wp), DIMENSION(:,:), POINTER :: dU10 ! dU [m/s] 656 REAL(wp), DIMENSION(:,:), POINTER :: dT ! air/sea temperature differeence [K] 657 REAL(wp), DIMENSION(:,:), POINTER :: dq ! air/sea humidity difference [K] 658 REAL(wp), DIMENSION(:,:), POINTER :: Cd_n10 ! 10m neutral drag coefficient 659 REAL(wp), DIMENSION(:,:), POINTER :: Ce_n10 ! 10m neutral latent coefficient 660 REAL(wp), DIMENSION(:,:), POINTER :: Ch_n10 ! 10m neutral sensible coefficient 661 REAL(wp), DIMENSION(:,:), POINTER :: sqrt_Cd_n10 ! root square of Cd_n10 662 REAL(wp), DIMENSION(:,:), POINTER :: sqrt_Cd ! root square of Cd 663 REAL(wp), DIMENSION(:,:), POINTER :: T_vpot ! virtual potential temperature [K] 664 REAL(wp), DIMENSION(:,:), POINTER :: T_star ! turbulent scale of tem. fluct. 665 REAL(wp), DIMENSION(:,:), POINTER :: q_star ! turbulent humidity of temp. fluct. 666 REAL(wp), DIMENSION(:,:), POINTER :: U_star ! turb. scale of velocity fluct. 667 REAL(wp), DIMENSION(:,:), POINTER :: L ! Monin-Obukov length [m] 668 REAL(wp), DIMENSION(:,:), POINTER :: zeta ! stability parameter at height zu 669 REAL(wp), DIMENSION(:,:), POINTER :: U_n10 ! neutral wind velocity at 10m [m] 670 REAL(wp), DIMENSION(:,:), POINTER :: xlogt, xct, zpsi_h, zpsi_m 671 672 INTEGER , DIMENSION(:,:), POINTER :: stab ! 1st guess stability test integer 664 673 !!---------------------------------------------------------------------- 665 666 IF( wrk_in_use(2, 14,15,16,17,18,19, & 667 20,21,22,23,24,25,26,27,28,29, & 668 30,31,32) .OR. & 669 iwrk_in_use(2, 1) ) THEN 670 CALL ctl_stop('TURB_CORE_1Z: requested workspace arrays unavailable') ; RETURN 671 ENDIF 674 ! 675 IF( nn_timing == 1 ) CALL timing_start('TURB_CORE_1Z') 676 ! 677 CALL wrk_alloc( jpi,jpj, stab ) ! integer 678 CALL wrk_alloc( jpi,jpj, dU10, dT, dq, Cd_n10, Ce_n10, Ch_n10, sqrt_Cd_n10, sqrt_Cd, L ) 679 CALL wrk_alloc( jpi,jpj, T_vpot, T_star, q_star, U_star, zeta, U_n10, xlogt, xct, zpsi_h, zpsi_m ) 672 680 673 681 !! * Start … … 682 690 !! Neutral Drag Coefficient 683 691 stab = 0.5 + sign(0.5,dT) ! stable : stab = 1 ; unstable : stab = 0 684 Cd_n10 = 1E-3 * ( 2.7/dU10 + 0.142 + dU10/13.09 ) ! L & Y eq. (6a) 692 IF ( ln_cdgw ) THEN 693 cdn_wave = cdn_wave - rsmall*(tmask(:,:,1)-1) 694 Cd_n10(:,:) = cdn_wave 695 ELSE 696 Cd_n10 = 1E-3 * ( 2.7/dU10 + 0.142 + dU10/13.09 ) ! L & Y eq. (6a) 697 ENDIF 685 698 sqrt_Cd_n10 = sqrt(Cd_n10) 686 699 Ce_n10 = 1E-3 * ( 34.6 * sqrt_Cd_n10 ) ! L & Y eq. (6b) … … 705 718 zpsi_m = psi_m(zeta) 706 719 707 !! Shifting the wind speed to 10m and neutral stability : 708 U_n10 = dU10*1./(1. + sqrt_Cd_n10/kappa*(log(zu/10.) - zpsi_m)) ! L & Y eq. (9a) 709 710 !! Updating the neutral 10m transfer coefficients : 711 Cd_n10 = 1E-3 * (2.7/U_n10 + 0.142 + U_n10/13.09) ! L & Y eq. (6a) 712 sqrt_Cd_n10 = sqrt(Cd_n10) 713 Ce_n10 = 1E-3 * (34.6 * sqrt_Cd_n10) ! L & Y eq. (6b) 714 stab = 0.5 + sign(0.5,zeta) 715 Ch_n10 = 1E-3*sqrt_Cd_n10*(18.*stab + 32.7*(1-stab)) ! L & Y eq. (6c), (6d) 716 717 !! Shifting the neutral 10m transfer coefficients to ( zu , zeta ) : 718 !! 719 xct = 1. + sqrt_Cd_n10/kappa*(log(zu/10) - zpsi_m) 720 Cd = Cd_n10/(xct*xct) ; sqrt_Cd = sqrt(Cd) 720 IF ( ln_cdgw ) THEN 721 sqrt_Cd=kappa/((kappa/sqrt_Cd_n10) - zpsi_m) ; Cd=sqrt_Cd*sqrt_Cd; 722 ELSE 723 !! Shifting the wind speed to 10m and neutral stability : 724 U_n10 = dU10*1./(1. + sqrt_Cd_n10/kappa*(log(zu/10.) - zpsi_m)) ! L & Y eq. (9a) 725 726 !! Updating the neutral 10m transfer coefficients : 727 Cd_n10 = 1E-3 * (2.7/U_n10 + 0.142 + U_n10/13.09) ! L & Y eq. (6a) 728 sqrt_Cd_n10 = sqrt(Cd_n10) 729 Ce_n10 = 1E-3 * (34.6 * sqrt_Cd_n10) ! L & Y eq. (6b) 730 stab = 0.5 + sign(0.5,zeta) 731 Ch_n10 = 1E-3*sqrt_Cd_n10*(18.*stab + 32.7*(1-stab)) ! L & Y eq. (6c), (6d) 732 733 !! Shifting the neutral 10m transfer coefficients to ( zu , zeta ) : 734 !! 735 xct = 1. + sqrt_Cd_n10/kappa*(log(zu/10) - zpsi_m) 736 Cd = Cd_n10/(xct*xct) ; sqrt_Cd = sqrt(Cd) 737 ENDIF 721 738 !! 722 739 xlogt = log(zu/10.) - zpsi_h … … 730 747 END DO 731 748 !! 732 IF( wrk_not_released(2, 14,15,16,17,18,19, &733 & 20,21,22,23,24,25,26,27,28,29, &734 & 30,31,32 ) .OR. &735 iwrk_not_released(2, 1) ) &736 CALL ctl_stop('TURB_CORE_1Z: failed to release workspace arrays')749 CALL wrk_dealloc( jpi,jpj, stab ) ! integer 750 CALL wrk_dealloc( jpi,jpj, dU10, dT, dq, Cd_n10, Ce_n10, Ch_n10, sqrt_Cd_n10, sqrt_Cd, L ) 751 CALL wrk_dealloc( jpi,jpj, T_vpot, T_star, q_star, U_star, zeta, U_n10, xlogt, xct, zpsi_h, zpsi_m ) 752 ! 753 IF( nn_timing == 1 ) CALL timing_stop('TURB_CORE_1Z') 737 754 ! 738 755 END SUBROUTINE TURB_CORE_1Z … … 754 771 !! References : Large & Yeager, 2004 : ??? 755 772 !!---------------------------------------------------------------------- 756 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released, iwrk_in_use, iwrk_not_released 757 USE wrk_nemo, ONLY: dU10 => wrk_2d_14 ! dU [m/s] 758 USE wrk_nemo, ONLY: dT => wrk_2d_15 ! air/sea temperature difference [K] 759 USE wrk_nemo, ONLY: dq => wrk_2d_16 ! air/sea humidity difference [K] 760 USE wrk_nemo, ONLY: Cd_n10 => wrk_2d_17 ! 10m neutral drag coefficient 761 USE wrk_nemo, ONLY: Ce_n10 => wrk_2d_18 ! 10m neutral latent coefficient 762 USE wrk_nemo, ONLY: Ch_n10 => wrk_2d_19 ! 10m neutral sensible coefficient 763 USE wrk_nemo, ONLY: sqrt_Cd_n10 => wrk_2d_20 ! root square of Cd_n10 764 USE wrk_nemo, ONLY: sqrt_Cd => wrk_2d_21 ! root square of Cd 765 USE wrk_nemo, ONLY: T_vpot => wrk_2d_22 ! virtual potential temperature [K] 766 USE wrk_nemo, ONLY: T_star => wrk_2d_23 ! turbulent scale of tem. fluct. 767 USE wrk_nemo, ONLY: q_star => wrk_2d_24 ! turbulent humidity of temp. fluct. 768 USE wrk_nemo, ONLY: U_star => wrk_2d_25 ! turb. scale of velocity fluct. 769 USE wrk_nemo, ONLY: L => wrk_2d_26 ! Monin-Obukov length [m] 770 USE wrk_nemo, ONLY: zeta_u => wrk_2d_27 ! stability parameter at height zu 771 USE wrk_nemo, ONLY: zeta_t => wrk_2d_28 ! stability parameter at height zt 772 USE wrk_nemo, ONLY: U_n10 => wrk_2d_29 ! neutral wind velocity at 10m [m] 773 USE wrk_nemo, ONLY: xlogt => wrk_2d_30, xct => wrk_2d_31, zpsi_hu => wrk_2d_32, zpsi_ht => wrk_2d_33, zpsi_m => wrk_2d_34 774 USE wrk_nemo, ONLY: stab => iwrk_2d_1 ! 1st guess stability test integer 775 !! 776 REAL(wp), INTENT(in) :: & 777 zt, & ! height for T_zt and q_zt [m] 778 zu ! height for dU [m] 779 REAL(wp), INTENT(in), DIMENSION(jpi,jpj) :: & 780 sst, & ! sea surface temperature [Kelvin] 781 T_zt, & ! potential air temperature [Kelvin] 782 q_sat, & ! sea surface specific humidity [kg/kg] 783 q_zt, & ! specific air humidity [kg/kg] 784 dU ! relative wind module |U(zu)-U(0)| [m/s] 785 REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: & 786 Cd, & ! transfer coefficient for momentum (tau) 787 Ch, & ! transfer coefficient for sensible heat (Q_sens) 788 Ce, & ! transfert coefficient for evaporation (Q_lat) 789 T_zu, & ! air temp. shifted at zu [K] 790 q_zu ! spec. hum. shifted at zu [kg/kg] 773 REAL(wp), INTENT(in ) :: zt ! height for T_zt and q_zt [m] 774 REAL(wp), INTENT(in ) :: zu ! height for dU [m] 775 REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: sst ! sea surface temperature [Kelvin] 776 REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: T_zt ! potential air temperature [Kelvin] 777 REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: q_sat ! sea surface specific humidity [kg/kg] 778 REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! specific air humidity [kg/kg] 779 REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: dU ! relative wind module |U(zu)-U(0)| [m/s] 780 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Cd ! transfer coefficient for momentum (tau) 781 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ch ! transfer coefficient for sensible heat (Q_sens) 782 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ce ! transfert coefficient for evaporation (Q_lat) 783 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: T_zu ! air temp. shifted at zu [K] 784 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: q_zu ! spec. hum. shifted at zu [kg/kg] 791 785 792 786 INTEGER :: j_itt 793 INTEGER, PARAMETER :: nb_itt = 3 ! number of itterations 794 REAL(wp), PARAMETER :: & 795 grav = 9.8, & ! gravity 796 kappa = 0.4 ! von Karman's constant 787 INTEGER , PARAMETER :: nb_itt = 3 ! number of itterations 788 REAL(wp), PARAMETER :: grav = 9.8 ! gravity 789 REAL(wp), PARAMETER :: kappa = 0.4 ! von Karman's constant 790 791 REAL(wp), DIMENSION(:,:), POINTER :: dU10 ! dU [m/s] 792 REAL(wp), DIMENSION(:,:), POINTER :: dT ! air/sea temperature differeence [K] 793 REAL(wp), DIMENSION(:,:), POINTER :: dq ! air/sea humidity difference [K] 794 REAL(wp), DIMENSION(:,:), POINTER :: Cd_n10 ! 10m neutral drag coefficient 795 REAL(wp), DIMENSION(:,:), POINTER :: Ce_n10 ! 10m neutral latent coefficient 796 REAL(wp), DIMENSION(:,:), POINTER :: Ch_n10 ! 10m neutral sensible coefficient 797 REAL(wp), DIMENSION(:,:), POINTER :: sqrt_Cd_n10 ! root square of Cd_n10 798 REAL(wp), DIMENSION(:,:), POINTER :: sqrt_Cd ! root square of Cd 799 REAL(wp), DIMENSION(:,:), POINTER :: T_vpot ! virtual potential temperature [K] 800 REAL(wp), DIMENSION(:,:), POINTER :: T_star ! turbulent scale of tem. fluct. 801 REAL(wp), DIMENSION(:,:), POINTER :: q_star ! turbulent humidity of temp. fluct. 802 REAL(wp), DIMENSION(:,:), POINTER :: U_star ! turb. scale of velocity fluct. 803 REAL(wp), DIMENSION(:,:), POINTER :: L ! Monin-Obukov length [m] 804 REAL(wp), DIMENSION(:,:), POINTER :: zeta_u ! stability parameter at height zu 805 REAL(wp), DIMENSION(:,:), POINTER :: zeta_t ! stability parameter at height zt 806 REAL(wp), DIMENSION(:,:), POINTER :: U_n10 ! neutral wind velocity at 10m [m] 807 REAL(wp), DIMENSION(:,:), POINTER :: xlogt, xct, zpsi_hu, zpsi_ht, zpsi_m 808 809 INTEGER , DIMENSION(:,:), POINTER :: stab ! 1st stability test integer 797 810 !!---------------------------------------------------------------------- 798 !! * Start 799 800 IF( wrk_in_use(2, 14,15,16,17,18,19, & 801 20,21,22,23,24,25,26,27,28,29, & 802 30,31,32,33,34) .OR. & 803 iwrk_in_use(2, 1) ) THEN 804 CALL ctl_stop('TURB_CORE_2Z: requested workspace arrays unavailable') ; RETURN 805 ENDIF 811 ! 812 IF( nn_timing == 1 ) CALL timing_start('TURB_CORE_2Z') 813 ! 814 CALL wrk_alloc( jpi,jpj, dU10, dT, dq, Cd_n10, Ce_n10, Ch_n10, sqrt_Cd_n10, sqrt_Cd, L ) 815 CALL wrk_alloc( jpi,jpj, T_vpot, T_star, q_star, U_star, zeta_u, zeta_t, U_n10 ) 816 CALL wrk_alloc( jpi,jpj, xlogt, xct, zpsi_hu, zpsi_ht, zpsi_m ) 817 CALL wrk_alloc( jpi,jpj, stab ) ! interger 806 818 807 819 !! Initial air/sea differences … … 812 824 !! Neutral Drag Coefficient : 813 825 stab = 0.5 + sign(0.5,dT) ! stab = 1 if dT > 0 -> STABLE 814 Cd_n10 = 1E-3*( 2.7/dU10 + 0.142 + dU10/13.09 ) 826 IF( ln_cdgw ) THEN 827 cdn_wave = cdn_wave - rsmall*(tmask(:,:,1)-1) 828 Cd_n10(:,:) = cdn_wave 829 ELSE 830 Cd_n10 = 1E-3*( 2.7/dU10 + 0.142 + dU10/13.09 ) 831 ENDIF 815 832 sqrt_Cd_n10 = sqrt(Cd_n10) 816 833 Ce_n10 = 1E-3*( 34.6 * sqrt_Cd_n10 ) … … 853 870 stab = 0.5 + sign(0.5,q_zu) ; q_zu = stab*q_zu 854 871 !! 855 !! Updating the neutral 10m transfer coefficients : 856 Cd_n10 = 1E-3 * (2.7/U_n10 + 0.142 + U_n10/13.09) ! L & Y eq. (6a) 857 sqrt_Cd_n10 = sqrt(Cd_n10) 858 Ce_n10 = 1E-3 * (34.6 * sqrt_Cd_n10) ! L & Y eq. (6b) 859 stab = 0.5 + sign(0.5,zeta_u) 860 Ch_n10 = 1E-3*sqrt_Cd_n10*(18.*stab + 32.7*(1-stab)) ! L & Y eq. (6c-6d) 861 !! 862 !! 863 !! Shifting the neutral 10m transfer coefficients to (zu,zeta_u) : 864 ! xct = 1. + sqrt_Cd_n10/kappa*(log(zu/10.) - psi_m(zeta_u)) 865 xct = 1. + sqrt_Cd_n10/kappa*(log(zu/10.) - zpsi_m) 866 Cd = Cd_n10/(xct*xct) ; sqrt_Cd = sqrt(Cd) 867 !! 868 ! xlogt = log(zu/10.) - psi_h(zeta_u) 872 IF( ln_cdgw ) THEN 873 sqrt_Cd=kappa/((kappa/sqrt_Cd_n10) - zpsi_m) ; Cd=sqrt_Cd*sqrt_Cd; 874 ELSE 875 !! Updating the neutral 10m transfer coefficients : 876 Cd_n10 = 1E-3 * (2.7/U_n10 + 0.142 + U_n10/13.09) ! L & Y eq. (6a) 877 sqrt_Cd_n10 = sqrt(Cd_n10) 878 Ce_n10 = 1E-3 * (34.6 * sqrt_Cd_n10) ! L & Y eq. (6b) 879 stab = 0.5 + sign(0.5,zeta_u) 880 Ch_n10 = 1E-3*sqrt_Cd_n10*(18.*stab + 32.7*(1-stab)) ! L & Y eq. (6c-6d) 881 !! 882 !! 883 !! Shifting the neutral 10m transfer coefficients to (zu,zeta_u) : 884 xct = 1. + sqrt_Cd_n10/kappa*(log(zu/10.) - zpsi_m) 885 Cd = Cd_n10/(xct*xct) ; sqrt_Cd = sqrt(Cd) 886 ENDIF 887 !! 869 888 xlogt = log(zu/10.) - zpsi_hu 870 889 !! … … 878 897 END DO 879 898 !! 880 IF( wrk_not_released(2, 14,15,16,17,18,19, & 881 & 20,21,22,23,24,25,26,27,28,29, & 882 & 30,31,32,33,34 ) .OR. & 883 iwrk_not_released(2, 1) ) & 884 CALL ctl_stop('TURB_CORE_2Z: failed to release workspace arrays') 899 CALL wrk_dealloc( jpi,jpj, dU10, dT, dq, Cd_n10, Ce_n10, Ch_n10, sqrt_Cd_n10, sqrt_Cd, L ) 900 CALL wrk_dealloc( jpi,jpj, T_vpot, T_star, q_star, U_star, zeta_u, zeta_t, U_n10 ) 901 CALL wrk_dealloc( jpi,jpj, xlogt, xct, zpsi_hu, zpsi_ht, zpsi_m ) 902 CALL wrk_dealloc( jpi,jpj, stab ) ! interger 903 ! 904 IF( nn_timing == 1 ) CALL timing_stop('TURB_CORE_2Z') 885 905 ! 886 906 END SUBROUTINE TURB_CORE_2Z … … 889 909 FUNCTION psi_m(zta) !! Psis, L & Y eq. (8c), (8d), (8e) 890 910 !------------------------------------------------------------------------------- 891 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released892 USE wrk_nemo, ONLY: X2 => wrk_2d_35893 USE wrk_nemo, ONLY: X => wrk_2d_36894 USE wrk_nemo, ONLY: stabit => wrk_2d_37895 !!896 911 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: zta 897 912 898 913 REAL(wp), PARAMETER :: pi = 3.141592653589793_wp 899 914 REAL(wp), DIMENSION(jpi,jpj) :: psi_m 915 REAL(wp), DIMENSION(:,:), POINTER :: X2, X, stabit 900 916 !------------------------------------------------------------------------------- 901 917 902 IF( wrk_in_use(2, 35,36,37) ) THEN 903 CALL ctl_stop('psi_m: requested workspace arrays unavailable') ; RETURN 904 ENDIF 918 CALL wrk_alloc( jpi,jpj, X2, X, stabit ) 905 919 906 920 X2 = sqrt(abs(1. - 16.*zta)) ; X2 = max(X2 , 1.0) ; X = sqrt(X2) … … 909 923 & + (1. - stabit)*(2*log((1. + X)/2) + log((1. + X2)/2) - 2*atan(X) + pi/2) ! Unstable 910 924 911 IF( wrk_not_released(2, 35,36,37) ) CALL ctl_stop('psi_m: failed to release workspace arrays')925 CALL wrk_dealloc( jpi,jpj, X2, X, stabit ) 912 926 ! 913 927 END FUNCTION psi_m … … 916 930 FUNCTION psi_h( zta ) !! Psis, L & Y eq. (8c), (8d), (8e) 917 931 !------------------------------------------------------------------------------- 918 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released919 USE wrk_nemo, ONLY: X2 => wrk_2d_35920 USE wrk_nemo, ONLY: X => wrk_2d_36921 USE wrk_nemo, ONLY: stabit => wrk_2d_37922 !923 932 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: zta 924 933 ! 925 934 REAL(wp), DIMENSION(jpi,jpj) :: psi_h 935 REAL(wp), DIMENSION(:,:), POINTER :: X2, X, stabit 926 936 !------------------------------------------------------------------------------- 927 937 928 IF( wrk_in_use(2, 35,36,37) ) THEN 929 CALL ctl_stop('psi_h: requested workspace arrays unavailable') ; RETURN 930 ENDIF 938 CALL wrk_alloc( jpi,jpj, X2, X, stabit ) 931 939 932 940 X2 = sqrt(abs(1. - 16.*zta)) ; X2 = max(X2 , 1.) ; X = sqrt(X2) … … 935 943 & + (1. - stabit)*(2.*log( (1. + X2)/2. )) ! Unstable 936 944 937 IF( wrk_not_released(2, 35,36,37) ) CALL ctl_stop('psi_h: failed to release workspace arrays')945 CALL wrk_dealloc( jpi,jpj, X2, X, stabit ) 938 946 ! 939 947 END FUNCTION psi_h -
trunk/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_mfs.F90
r3292 r3294 20 20 USE in_out_manager ! I/O manager 21 21 USE lib_mpp ! distribued memory computing library 22 USE wrk_nemo ! work arrays 23 USE timing ! Timing 22 24 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 23 25 USE prtctl ! Print control … … 119 121 & sn_tair , sn_rhm , sn_prec 120 122 !!--------------------------------------------------------------------- 121 123 ! 124 IF( nn_timing == 1 ) CALL timing_start('sbc_blk_mfs') 125 ! 122 126 ! ! ====================== ! 123 127 IF( kt == nit000 ) THEN ! First call kt=nit000 ! … … 262 266 263 267 ENDIF 264 268 ! 269 IF( nn_timing == 1 ) CALL timing_stop('sbc_blk_mfs') 270 ! 265 271 END SUBROUTINE sbc_blk_mfs 266 272 … … 283 289 !! 284 290 !!---------------------------------------------------------------------- 285 !!286 287 291 USE sbcblk_core, ONLY: turb_core_2z ! For wave coupling and Tair/rh from 2 to 10m 288 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released289 USE wrk_nemo, ONLY: rspeed => wrk_2d_1290 USE wrk_nemo, ONLY: sh10now => wrk_2d_2291 USE wrk_nemo, ONLY: t10now => wrk_2d_3292 USE wrk_nemo, ONLY: cdx => wrk_2d_4 ! --- drag coeff.293 USE wrk_nemo, ONLY: ce => wrk_2d_5 ! --- turbulent exchange coefficients294 USE wrk_nemo, ONLY: shms => wrk_2d_6295 USE wrk_nemo, ONLY: rhom => wrk_2d_7296 USE wrk_nemo, ONLY: sstk => wrk_2d_8297 USE wrk_nemo, ONLY: ch => wrk_2d_10298 USE wrk_nemo, ONLY: rel_windu => wrk_2d_11299 USE wrk_nemo, ONLY: rel_windv => wrk_2d_12300 292 301 293 REAL(wp), INTENT(in ) :: hour … … 310 302 REAL(wp) :: esre, cseep 311 303 304 REAL(wp), DIMENSION (:,:), POINTER :: rspeed, sh10now, t10now, cdx, ce, shms 305 REAL(wp), DIMENSION (:,:), POINTER :: rhom, sstk, ch, rel_windu, rel_windv 312 306 !!---------------------------------------------------------------------- 313 307 !! coefficients ( in MKS ) : … … 335 329 REAL(wp), DIMENSION(5) :: p_e = (/-0.16,1.0,1.0,1.0,1.0/) 336 330 INTEGER :: kku !index varing with wind speed 337 338 ! Set-up access to workspace arrays339 IF( wrk_in_use(2, 1,2,3,4,5,6,7,8,10,11,12) ) THEN340 CALL ctl_stop('blk_mfs: requested workspace arrays unavailable') ; RETURN341 END IF331 ! 332 IF( nn_timing == 1 ) CALL timing_start('fluxes_mfs') 333 ! 334 CALL wrk_alloc( jpi,jpj, rspeed, sh10now, t10now, cdx, ce, shms ) 335 CALL wrk_alloc( jpi,jpj, rhom, sstk, ch, rel_windu, rel_windv ) 342 336 343 337 !!---------------------------------------------------------------------- … … 501 495 tauy(:,:)= rhom(:,:) * cdx(:,:) * rspeed(:,:) * rel_windv(:,:) 502 496 503 504 IF( wrk_not_released(2, 1,2,3,4,5,6,7,8,10,11,12) ) &505 CALL ctl_stop('fluxes_mfs: failed to release workspace arrays')506 507 497 CALL wrk_dealloc( jpi,jpj, rspeed, sh10now, t10now, cdx, ce, shms ) 498 CALL wrk_dealloc( jpi,jpj, rhom, sstk, ch, rel_windu, rel_windv ) 499 ! 500 IF( nn_timing == 1 ) CALL timing_stop('fluxes_mfs') 501 ! 508 502 END SUBROUTINE fluxes_mfs 509 503 -
trunk/NEMOGCM/NEMO/OPA_SRC/SBC/sbccpl.F90
r2715 r3294 7 7 !! 3.0 ! 2008-02 (G. Madec, C Talandier) surface module 8 8 !! 3.1 ! 2009_02 (G. Madec, S. Masson, E. Maisonave, A. Caubel) generic coupled interface 9 !! 3.4 ! 2011_11 (C. Harris) more flexibility + multi-category fields 9 10 !!---------------------------------------------------------------------- 10 11 #if defined key_oasis3 || defined key_oasis4 … … 41 42 USE geo2ocean ! 42 43 USE restart ! 43 USE oce , ONLY : t n, un, vn44 USE oce , ONLY : tsn, un, vn 44 45 USE albedo ! 45 46 USE in_out_manager ! I/O manager 46 47 USE iom ! NetCDF library 47 48 USE lib_mpp ! distribued memory computing library 49 USE wrk_nemo ! work arrays 50 USE timing ! Timing 48 51 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 49 52 #if defined key_cpl_carbon_cycle … … 51 54 #endif 52 55 USE diaar5, ONLY : lk_diaar5 56 #if defined key_cice 57 USE ice_domain_size, only: ncat 58 #endif 53 59 IMPLICIT NONE 54 60 PRIVATE … … 89 95 INTEGER, PARAMETER :: jpr_cal = 29 ! calving 90 96 INTEGER, PARAMETER :: jpr_taum = 30 ! wind stress module 91 #if ! defined key_cpl_carbon_cycle92 INTEGER, PARAMETER :: jprcv = 30 ! total number of fields received93 #else94 97 INTEGER, PARAMETER :: jpr_co2 = 31 95 INTEGER, PARAMETER :: jprcv = 31 ! total number of fields received 96 #endif 98 INTEGER, PARAMETER :: jpr_topm = 32 ! topmeltn 99 INTEGER, PARAMETER :: jpr_botm = 33 ! botmeltn 100 INTEGER, PARAMETER :: jprcv = 33 ! total number of fields received 101 97 102 INTEGER, PARAMETER :: jps_fice = 1 ! ice fraction 98 103 INTEGER, PARAMETER :: jps_toce = 2 ! ocean temperature … … 109 114 INTEGER, PARAMETER :: jps_ivy1 = 13 ! 110 115 INTEGER, PARAMETER :: jps_ivz1 = 14 ! 111 #if ! defined key_cpl_carbon_cycle112 INTEGER, PARAMETER :: jpsnd = 14 ! total number of fields sended113 #else114 116 INTEGER, PARAMETER :: jps_co2 = 15 115 117 INTEGER, PARAMETER :: jpsnd = 15 ! total number of fields sended 116 #endif 118 117 119 ! !!** namelist namsbc_cpl ** 118 ! Send to the atmosphere ! 119 CHARACTER(len=100) :: cn_snd_temperature = 'oce only' ! 'oce only' 'weighted oce and ice' or 'mixed oce-ice' 120 CHARACTER(len=100) :: cn_snd_albedo = 'none' ! 'none' 'weighted ice' or 'mixed oce-ice' 121 CHARACTER(len=100) :: cn_snd_thickness = 'none' ! 'none' or 'weighted ice and snow' 122 CHARACTER(len=100) :: cn_snd_crt_nature = 'none' ! 'none' 'oce only' 'weighted oce and ice' or 'mixed oce-ice' 123 CHARACTER(len=100) :: cn_snd_crt_refere = 'spherical' ! 'spherical' or 'cartesian' 124 CHARACTER(len=100) :: cn_snd_crt_orient = 'local grid' ! 'eastward-northward' or 'local grid' 125 CHARACTER(len=100) :: cn_snd_crt_grid = 'T' ! always at 'T' point 126 #if defined key_cpl_carbon_cycle 127 CHARACTER(len=100) :: cn_snd_co2 = 'none' ! 'none' or 'coupled' 120 TYPE :: FLD_C 121 CHARACTER(len = 32) :: cldes ! desciption of the coupling strategy 122 CHARACTER(len = 32) :: clcat ! multiple ice categories strategy 123 CHARACTER(len = 32) :: clvref ! reference of vector ('spherical' or 'cartesian') 124 CHARACTER(len = 32) :: clvor ! orientation of vector fields ('eastward-northward' or 'local grid') 125 CHARACTER(len = 32) :: clvgrd ! grids on which is located the vector fields 126 END TYPE FLD_C 127 ! Send to the atmosphere ! 128 TYPE(FLD_C) :: sn_snd_temp, sn_snd_alb, sn_snd_thick, sn_snd_crt, sn_snd_co2 129 ! Received from the atmosphere ! 130 TYPE(FLD_C) :: sn_rcv_w10m, sn_rcv_taumod, sn_rcv_tau, sn_rcv_dqnsdt, sn_rcv_qsr, sn_rcv_qns, sn_rcv_emp, sn_rcv_rnf 131 TYPE(FLD_C) :: sn_rcv_cal, sn_rcv_iceflx, sn_rcv_co2 132 133 TYPE :: DYNARR 134 REAL(wp), POINTER, DIMENSION(:,:,:) :: z3 135 END TYPE DYNARR 136 137 TYPE( DYNARR ), SAVE, DIMENSION(jprcv) :: frcv ! all fields recieved from the atmosphere 138 139 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: albedo_oce_mix ! ocean albedo sent to atmosphere (mix clear/overcast sky) 140 141 INTEGER , ALLOCATABLE, SAVE, DIMENSION( :) :: nrcvinfo ! OASIS info argument 142 143 #if ! defined key_lim2 && ! defined key_lim3 144 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_ice, v_ice,fr1_i0,fr2_i0 ! jpi, jpj 145 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: tn_ice, alb_ice, qns_ice, dqns_ice ! (jpi,jpj,jpl) 128 146 #endif 129 ! Received from the atmosphere ! 130 CHARACTER(len=100) :: cn_rcv_tau_nature = 'oce only' ! 'oce only' 'oce and ice' or 'mixed oce-ice' 131 CHARACTER(len=100) :: cn_rcv_tau_refere = 'spherical' ! 'spherical' or 'cartesian' 132 CHARACTER(len=100) :: cn_rcv_tau_orient = 'local grid' ! 'eastward-northward' or 'local grid' 133 CHARACTER(len=100) :: cn_rcv_tau_grid = 'T' ! 'T', 'U,V', 'U,V,I', 'T,I', or 'T,U,V' 134 CHARACTER(len=100) :: cn_rcv_w10m = 'none' ! 'none' or 'coupled' 135 CHARACTER(len=100) :: cn_rcv_dqnsdt = 'none' ! 'none' or 'coupled' 136 CHARACTER(len=100) :: cn_rcv_qsr = 'oce only' ! 'oce only' 'conservative' 'oce and ice' or 'mixed oce-ice' 137 CHARACTER(len=100) :: cn_rcv_qns = 'oce only' ! 'oce only' 'conservative' 'oce and ice' or 'mixed oce-ice' 138 CHARACTER(len=100) :: cn_rcv_emp = 'oce only' ! 'oce only' 'conservative' or 'oce and ice' 139 CHARACTER(len=100) :: cn_rcv_rnf = 'coupled' ! 'coupled' 'climato' or 'mixed' 140 CHARACTER(len=100) :: cn_rcv_cal = 'none' ! 'none' or 'coupled' 141 CHARACTER(len=100) :: cn_rcv_taumod = 'none' ! 'none' or 'coupled' 142 #if defined key_cpl_carbon_cycle 143 CHARACTER(len=100) :: cn_rcv_co2 = 'none' ! 'none' or 'coupled' 147 148 #if defined key_cice 149 INTEGER, PARAMETER :: jpl = ncat 150 #elif ! defined key_lim2 && ! defined key_lim3 151 INTEGER, PARAMETER :: jpl = 1 152 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp_ice 153 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qsr_ice 144 154 #endif 145 155 146 !! CHARACTER(len=100), PUBLIC :: cn_rcv_rnf !: ??? ==>> !!gm treat this case in a different maner 147 148 CHARACTER(len=100), DIMENSION(4) :: cn_snd_crt ! array combining cn_snd_crt_* 149 CHARACTER(len=100), DIMENSION(4) :: cn_rcv_tau ! array combining cn_rcv_tau_* 150 151 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: albedo_oce_mix ! ocean albedo sent to atmosphere (mix clear/overcast sky) 152 153 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: frcv ! all fields recieved from the atmosphere 154 INTEGER , ALLOCATABLE, SAVE, DIMENSION( :) :: nrcvinfo ! OASIS info argument 155 156 #if ! defined key_lim2 && ! defined key_lim3 157 ! quick patch to be able to run the coupled model without sea-ice... 158 INTEGER, PARAMETER :: jpl = 1 159 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: hicif, hsnif, u_ice, v_ice,fr1_i0,fr2_i0 ! jpi, jpj 160 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: tn_ice, alb_ice ! (jpi,jpj,jpl) 161 REAL(wp) :: lfus 156 #if ! defined key_lim3 && ! defined key_cice 157 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_i 158 #endif 159 160 #if ! defined key_lim3 161 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ht_i, ht_s 162 #endif 163 164 #if ! defined key_cice 165 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: topmelt, botmelt 162 166 #endif 163 167 … … 176 180 !! *** FUNCTION sbc_cpl_alloc *** 177 181 !!---------------------------------------------------------------------- 178 INTEGER :: ierr( 2)182 INTEGER :: ierr(4),jn 179 183 !!---------------------------------------------------------------------- 180 184 ierr(:) = 0 181 185 ! 182 ALLOCATE( albedo_oce_mix(jpi,jpj), frcv(jpi,jpj,jprcv),nrcvinfo(jprcv), STAT=ierr(1) )186 ALLOCATE( albedo_oce_mix(jpi,jpj), nrcvinfo(jprcv), STAT=ierr(1) ) 183 187 ! 184 188 #if ! defined key_lim2 && ! defined key_lim3 185 189 ! quick patch to be able to run the coupled model without sea-ice... 186 ALLOCATE( hicif(jpi,jpj) , u_ice(jpi,jpj) , fr1_i0(jpi,jpj) , tn_ice (jpi,jpj,jpl) , & 187 hsnif(jpi,jpj) , v_ice(jpi,jpj) , fr2_i0(jpi,jpj) , alb_ice(jpi,jpj,jpl) , STAT=ierr(2) ) 190 ALLOCATE( u_ice(jpi,jpj) , fr1_i0(jpi,jpj) , tn_ice (jpi,jpj,1) , & 191 v_ice(jpi,jpj) , fr2_i0(jpi,jpj) , alb_ice(jpi,jpj,1), & 192 emp_ice(jpi,jpj) , qns_ice(jpi,jpj,1) , dqns_ice(jpi,jpj,1) , STAT=ierr(2) ) 193 #endif 194 195 #if ! defined key_lim3 && ! defined key_cice 196 ALLOCATE( a_i(jpi,jpj,jpl) , STAT=ierr(3) ) 197 #endif 198 199 #if defined key_cice || defined key_lim2 200 ALLOCATE( ht_i(jpi,jpj,jpl) , ht_s(jpi,jpj,jpl) , STAT=ierr(4) ) 188 201 #endif 189 202 sbc_cpl_alloc = MAXVAL( ierr ) … … 206 219 !! * initialise the OASIS coupler 207 220 !!---------------------------------------------------------------------- 208 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released209 USE wrk_nemo, ONLY: zacs => wrk_2d_3 , zaos => wrk_2d_4 ! clear & overcast sky albedos210 !!211 221 INTEGER, INTENT(in) :: k_ice ! ice management in the sbc (=0/1/2/3) 212 222 !! 213 223 INTEGER :: jn ! dummy loop index 214 !! 215 NAMELIST/namsbc_cpl/ cn_snd_temperature, cn_snd_albedo , cn_snd_thickness, & 216 cn_snd_crt_nature, cn_snd_crt_refere , cn_snd_crt_orient, cn_snd_crt_grid , & 217 cn_rcv_w10m , cn_rcv_taumod , & 218 cn_rcv_tau_nature, cn_rcv_tau_refere , cn_rcv_tau_orient, cn_rcv_tau_grid , & 219 cn_rcv_dqnsdt , cn_rcv_qsr , cn_rcv_qns , cn_rcv_emp , cn_rcv_rnf , cn_rcv_cal 220 #if defined key_cpl_carbon_cycle 221 NAMELIST/namsbc_cpl_co2/ cn_snd_co2, cn_rcv_co2 222 #endif 224 REAL(wp), POINTER, DIMENSION(:,:) :: zacs, zaos 225 !! 226 NAMELIST/namsbc_cpl/ sn_snd_temp, sn_snd_alb , sn_snd_thick, sn_snd_crt , sn_snd_co2, & 227 & sn_rcv_w10m, sn_rcv_taumod, sn_rcv_tau , sn_rcv_dqnsdt, sn_rcv_qsr, & 228 & sn_rcv_qns , sn_rcv_emp , sn_rcv_rnf , sn_rcv_cal , sn_rcv_iceflx , sn_rcv_co2 223 229 !!--------------------------------------------------------------------- 224 225 IF( wrk_in_use(2, 3,4) ) THEN226 CALL ctl_stop('sbc_cpl_init: requested workspace arrays unavailable') ; RETURN227 ENDIF230 ! 231 IF( nn_timing == 1 ) CALL timing_start('sbc_cpl_init') 232 ! 233 CALL wrk_alloc( jpi,jpj, zacs, zaos ) 228 234 229 235 ! ================================ ! 230 236 ! Namelist informations ! 231 237 ! ================================ ! 238 239 ! default definitions 240 ! ! description ! multiple ! vector ! vector ! vector ! 241 ! ! ! categories ! reference ! orientation ! grids ! 242 ! send 243 sn_snd_temp = FLD_C( 'weighted oce and ice', 'no' , '' , '' , '' ) 244 sn_snd_alb = FLD_C( 'weighted ice' , 'no' , '' , '' , '' ) 245 sn_snd_thick = FLD_C( 'none' , 'no' , '' , '' , '' ) 246 sn_snd_crt = FLD_C( 'none' , 'no' , 'spherical' , 'eastward-northward' , 'T' ) 247 sn_snd_co2 = FLD_C( 'none' , 'no' , '' , '' , '' ) 248 ! receive 249 sn_rcv_w10m = FLD_C( 'none' , 'no' , '' , '' , '' ) 250 sn_rcv_taumod = FLD_C( 'coupled' , 'no' , '' , '' , '' ) 251 sn_rcv_tau = FLD_C( 'oce only' , 'no' , 'cartesian' , 'eastward-northward', 'U,V' ) 252 sn_rcv_dqnsdt = FLD_C( 'coupled' , 'no' , '' , '' , '' ) 253 sn_rcv_qsr = FLD_C( 'oce and ice' , 'no' , '' , '' , '' ) 254 sn_rcv_qns = FLD_C( 'oce and ice' , 'no' , '' , '' , '' ) 255 sn_rcv_emp = FLD_C( 'conservative' , 'no' , '' , '' , '' ) 256 sn_rcv_rnf = FLD_C( 'coupled' , 'no' , '' , '' , '' ) 257 sn_rcv_cal = FLD_C( 'coupled' , 'no' , '' , '' , '' ) 258 sn_rcv_iceflx = FLD_C( 'none' , 'no' , '' , '' , '' ) 259 sn_rcv_co2 = FLD_C( 'none' , 'no' , '' , '' , '' ) 232 260 233 261 REWIND( numnam ) ! ... read namlist namsbc_cpl … … 238 266 WRITE(numout,*)'sbc_cpl_init : namsbc_cpl namelist ' 239 267 WRITE(numout,*)'~~~~~~~~~~~~' 240 WRITE(numout,*)' received fields' 241 WRITE(numout,*)' 10m wind module cn_rcv_w10m = ', cn_rcv_w10m 242 WRITE(numout,*)' surface stress - nature cn_rcv_tau_nature = ', cn_rcv_tau_nature 243 WRITE(numout,*)' - referential cn_rcv_tau_refere = ', cn_rcv_tau_refere 244 WRITE(numout,*)' - orientation cn_rcv_tau_orient = ', cn_rcv_tau_orient 245 WRITE(numout,*)' - mesh cn_rcv_tau_grid = ', cn_rcv_tau_grid 246 WRITE(numout,*)' non-solar heat flux sensitivity cn_rcv_dqnsdt = ', cn_rcv_dqnsdt 247 WRITE(numout,*)' solar heat flux cn_rcv_qsr = ', cn_rcv_qsr 248 WRITE(numout,*)' non-solar heat flux cn_rcv_qns = ', cn_rcv_qns 249 WRITE(numout,*)' freshwater budget cn_rcv_emp = ', cn_rcv_emp 250 WRITE(numout,*)' runoffs cn_rcv_rnf = ', cn_rcv_rnf 251 WRITE(numout,*)' calving cn_rcv_cal = ', cn_rcv_cal 252 WRITE(numout,*)' stress module cn_rcv_taumod = ', cn_rcv_taumod 253 WRITE(numout,*)' sent fields' 254 WRITE(numout,*)' surface temperature cn_snd_temperature = ', cn_snd_temperature 255 WRITE(numout,*)' albedo cn_snd_albedo = ', cn_snd_albedo 256 WRITE(numout,*)' ice/snow thickness cn_snd_thickness = ', cn_snd_thickness 257 WRITE(numout,*)' surface current - nature cn_snd_crt_nature = ', cn_snd_crt_nature 258 WRITE(numout,*)' - referential cn_snd_crt_refere = ', cn_snd_crt_refere 259 WRITE(numout,*)' - orientation cn_snd_crt_orient = ', cn_snd_crt_orient 260 WRITE(numout,*)' - mesh cn_snd_crt_grid = ', cn_snd_crt_grid 261 ENDIF 262 263 #if defined key_cpl_carbon_cycle 264 REWIND( numnam ) ! read namlist namsbc_cpl_co2 265 READ ( numnam, namsbc_cpl_co2 ) 266 IF(lwp) THEN ! control print 267 WRITE(numout,*) 268 WRITE(numout,*)'sbc_cpl_init : namsbc_cpl_co2 namelist ' 269 WRITE(numout,*)'~~~~~~~~~~~~' 270 WRITE(numout,*)' received fields' 271 WRITE(numout,*)' atm co2 cn_rcv_co2 = ', cn_rcv_co2 272 WRITE(numout,*)' sent fields' 273 WRITE(numout,*)' oce co2 flux cn_snd_co2 = ', cn_snd_co2 274 WRITE(numout,*) 275 ENDIF 276 #endif 277 ! save current & stress in an array and suppress possible blank in the name 278 cn_snd_crt(1) = TRIM( cn_snd_crt_nature ) ; cn_snd_crt(2) = TRIM( cn_snd_crt_refere ) 279 cn_snd_crt(3) = TRIM( cn_snd_crt_orient ) ; cn_snd_crt(4) = TRIM( cn_snd_crt_grid ) 280 cn_rcv_tau(1) = TRIM( cn_rcv_tau_nature ) ; cn_rcv_tau(2) = TRIM( cn_rcv_tau_refere ) 281 cn_rcv_tau(3) = TRIM( cn_rcv_tau_orient ) ; cn_rcv_tau(4) = TRIM( cn_rcv_tau_grid ) 282 283 ! ! allocate zdfric arrays 268 WRITE(numout,*)' received fields (mutiple ice categogies)' 269 WRITE(numout,*)' 10m wind module = ', TRIM(sn_rcv_w10m%cldes ), ' (', TRIM(sn_rcv_w10m%clcat ), ')' 270 WRITE(numout,*)' stress module = ', TRIM(sn_rcv_taumod%cldes), ' (', TRIM(sn_rcv_taumod%clcat), ')' 271 WRITE(numout,*)' surface stress = ', TRIM(sn_rcv_tau%cldes ), ' (', TRIM(sn_rcv_tau%clcat ), ')' 272 WRITE(numout,*)' - referential = ', sn_rcv_tau%clvref 273 WRITE(numout,*)' - orientation = ', sn_rcv_tau%clvor 274 WRITE(numout,*)' - mesh = ', sn_rcv_tau%clvgrd 275 WRITE(numout,*)' non-solar heat flux sensitivity = ', TRIM(sn_rcv_dqnsdt%cldes), ' (', TRIM(sn_rcv_dqnsdt%clcat), ')' 276 WRITE(numout,*)' solar heat flux = ', TRIM(sn_rcv_qsr%cldes ), ' (', TRIM(sn_rcv_qsr%clcat ), ')' 277 WRITE(numout,*)' non-solar heat flux = ', TRIM(sn_rcv_qns%cldes ), ' (', TRIM(sn_rcv_qns%clcat ), ')' 278 WRITE(numout,*)' freshwater budget = ', TRIM(sn_rcv_emp%cldes ), ' (', TRIM(sn_rcv_emp%clcat ), ')' 279 WRITE(numout,*)' runoffs = ', TRIM(sn_rcv_rnf%cldes ), ' (', TRIM(sn_rcv_rnf%clcat ), ')' 280 WRITE(numout,*)' calving = ', TRIM(sn_rcv_cal%cldes ), ' (', TRIM(sn_rcv_cal%clcat ), ')' 281 WRITE(numout,*)' sea ice heat fluxes = ', TRIM(sn_rcv_iceflx%cldes), ' (', TRIM(sn_rcv_iceflx%clcat), ')' 282 WRITE(numout,*)' atm co2 = ', TRIM(sn_rcv_co2%cldes ), ' (', TRIM(sn_rcv_co2%clcat ), ')' 283 WRITE(numout,*)' sent fields (multiple ice categories)' 284 WRITE(numout,*)' surface temperature = ', TRIM(sn_snd_temp%cldes ), ' (', TRIM(sn_snd_temp%clcat ), ')' 285 WRITE(numout,*)' albedo = ', TRIM(sn_snd_alb%cldes ), ' (', TRIM(sn_snd_alb%clcat ), ')' 286 WRITE(numout,*)' ice/snow thickness = ', TRIM(sn_snd_thick%cldes ), ' (', TRIM(sn_snd_thick%clcat ), ')' 287 WRITE(numout,*)' surface current = ', TRIM(sn_snd_crt%cldes ), ' (', TRIM(sn_snd_crt%clcat ), ')' 288 WRITE(numout,*)' - referential = ', sn_snd_crt%clvref 289 WRITE(numout,*)' - orientation = ', sn_snd_crt%clvor 290 WRITE(numout,*)' - mesh = ', sn_snd_crt%clvgrd 291 WRITE(numout,*)' oce co2 flux = ', TRIM(sn_snd_co2%cldes ), ' (', TRIM(sn_snd_co2%clcat ), ')' 292 ENDIF 293 294 ! ! allocate sbccpl arrays 284 295 IF( sbc_cpl_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_cpl_alloc : unable to allocate arrays' ) 285 296 … … 294 305 295 306 ! default definitions of srcv 296 srcv(:)%laction = .FALSE. ; srcv(:)%clgrid = 'T' ; srcv(:)%nsgn = 1. 307 srcv(:)%laction = .FALSE. ; srcv(:)%clgrid = 'T' ; srcv(:)%nsgn = 1. ; srcv(:)%nct = 1 297 308 298 309 ! ! ------------------------- ! … … 315 326 ! 316 327 ! Vectors: change of sign at north fold ONLY if on the local grid 317 IF( TRIM( cn_rcv_tau(3)) == 'local grid' ) srcv(jpr_otx1:jpr_itz2)%nsgn = -1.328 IF( TRIM( sn_rcv_tau%clvor ) == 'local grid' ) srcv(jpr_otx1:jpr_itz2)%nsgn = -1. 318 329 319 330 ! ! Set grid and action 320 SELECT CASE( TRIM( cn_rcv_tau(4)) ) ! 'T', 'U,V', 'U,V,I', 'U,V,F', 'T,I', 'T,F', or 'T,U,V'331 SELECT CASE( TRIM( sn_rcv_tau%clvgrd ) ) ! 'T', 'U,V', 'U,V,I', 'U,V,F', 'T,I', 'T,F', or 'T,U,V' 321 332 CASE( 'T' ) 322 333 srcv(jpr_otx1:jpr_itz2)%clgrid = 'T' ! oce and ice components given at T-point … … 364 375 srcv(jpr_itx1:jpr_itz2)%laction = .TRUE. ! receive ice components on grid 1 & 2 365 376 CASE default 366 CALL ctl_stop( 'sbc_cpl_init: wrong definition of cn_rcv_tau(4)' )377 CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_rcv_tau%clvgrd' ) 367 378 END SELECT 368 379 ! 369 IF( TRIM( cn_rcv_tau(2)) == 'spherical' ) & ! spherical: 3rd component not received380 IF( TRIM( sn_rcv_tau%clvref ) == 'spherical' ) & ! spherical: 3rd component not received 370 381 & srcv( (/jpr_otz1, jpr_otz2, jpr_itz1, jpr_itz2/) )%laction = .FALSE. 371 382 ! 372 IF( TRIM( cn_rcv_tau(1)) /= 'oce and ice' ) THEN ! 'oce and ice' case ocean stress on ocean mesh used383 IF( TRIM( sn_rcv_tau%cldes ) /= 'oce and ice' ) THEN ! 'oce and ice' case ocean stress on ocean mesh used 373 384 srcv(jpr_itx1:jpr_itz2)%laction = .FALSE. ! ice components not received 374 385 srcv(jpr_itx1)%clgrid = 'U' ! ocean stress used after its transformation … … 388 399 srcv(jpr_semp)%clname = 'OISubMSn' ! ice solid water budget = sublimation - solid precipitation 389 400 srcv(jpr_oemp)%clname = 'OOEvaMPr' ! ocean water budget = ocean Evap - ocean precip 390 SELECT CASE( TRIM( cn_rcv_emp) )401 SELECT CASE( TRIM( sn_rcv_emp%cldes ) ) 391 402 CASE( 'oce only' ) ; srcv( jpr_oemp )%laction = .TRUE. 392 403 CASE( 'conservative' ) ; srcv( (/jpr_rain, jpr_snow, jpr_ievp, jpr_tevp/) )%laction = .TRUE. 393 404 CASE( 'oce and ice' ) ; srcv( (/jpr_ievp, jpr_sbpr, jpr_semp, jpr_oemp/) )%laction = .TRUE. 394 CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of cn_rcv_emp' )405 CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_rcv_emp%cldes' ) 395 406 END SELECT 396 407 … … 398 409 ! ! Runoffs & Calving ! 399 410 ! ! ------------------------- ! 400 srcv(jpr_rnf )%clname = 'O_Runoff' ; IF( TRIM( cn_rcv_rnf ) == 'coupled' ) srcv(jpr_rnf)%laction = .TRUE. 401 IF( TRIM( cn_rcv_rnf ) == 'climato' ) THEN ; ln_rnf = .TRUE. 402 ELSE ; ln_rnf = .FALSE. 403 ENDIF 404 srcv(jpr_cal )%clname = 'OCalving' ; IF( TRIM( cn_rcv_cal ) == 'coupled' ) srcv(jpr_cal)%laction = .TRUE. 411 srcv(jpr_rnf )%clname = 'O_Runoff' ; IF( TRIM( sn_rcv_rnf%cldes ) == 'coupled' ) srcv(jpr_rnf)%laction = .TRUE. 412 ! This isn't right - really just want ln_rnf_emp changed 413 ! IF( TRIM( sn_rcv_rnf%cldes ) == 'climato' ) THEN ; ln_rnf = .TRUE. 414 ! ELSE ; ln_rnf = .FALSE. 415 ! ENDIF 416 srcv(jpr_cal )%clname = 'OCalving' ; IF( TRIM( sn_rcv_cal%cldes ) == 'coupled' ) srcv(jpr_cal)%laction = .TRUE. 405 417 406 418 ! ! ------------------------- ! … … 410 422 srcv(jpr_qnsice)%clname = 'O_QnsIce' 411 423 srcv(jpr_qnsmix)%clname = 'O_QnsMix' 412 SELECT CASE( TRIM( cn_rcv_qns ) )424 SELECT CASE( TRIM( sn_rcv_qns%cldes ) ) 413 425 CASE( 'oce only' ) ; srcv( jpr_qnsoce )%laction = .TRUE. 414 426 CASE( 'conservative' ) ; srcv( (/jpr_qnsice, jpr_qnsmix/) )%laction = .TRUE. 415 427 CASE( 'oce and ice' ) ; srcv( (/jpr_qnsice, jpr_qnsoce/) )%laction = .TRUE. 416 428 CASE( 'mixed oce-ice' ) ; srcv( jpr_qnsmix )%laction = .TRUE. 417 CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of cn_rcv_qns' )429 CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_rcv_qns%cldes' ) 418 430 END SELECT 419 431 IF( TRIM( sn_rcv_qns%cldes ) == 'mixed oce-ice' .AND. jpl > 1 ) & 432 CALL ctl_stop( 'sbc_cpl_init: sn_rcv_qns%cldes not currently allowed to be mixed oce-ice for multi-category ice' ) 420 433 ! ! ------------------------- ! 421 434 ! ! solar radiation ! Qsr … … 424 437 srcv(jpr_qsrice)%clname = 'O_QsrIce' 425 438 srcv(jpr_qsrmix)%clname = 'O_QsrMix' 426 SELECT CASE( TRIM( cn_rcv_qsr) )439 SELECT CASE( TRIM( sn_rcv_qsr%cldes ) ) 427 440 CASE( 'oce only' ) ; srcv( jpr_qsroce )%laction = .TRUE. 428 441 CASE( 'conservative' ) ; srcv( (/jpr_qsrice, jpr_qsrmix/) )%laction = .TRUE. 429 442 CASE( 'oce and ice' ) ; srcv( (/jpr_qsrice, jpr_qsroce/) )%laction = .TRUE. 430 443 CASE( 'mixed oce-ice' ) ; srcv( jpr_qsrmix )%laction = .TRUE. 431 CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of cn_rcv_qsr' )444 CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_rcv_qsr%cldes' ) 432 445 END SELECT 433 446 IF( TRIM( sn_rcv_qsr%cldes ) == 'mixed oce-ice' .AND. jpl > 1 ) & 447 CALL ctl_stop( 'sbc_cpl_init: sn_rcv_qsr%cldes not currently allowed to be mixed oce-ice for multi-category ice' ) 434 448 ! ! ------------------------- ! 435 449 ! ! non solar sensitivity ! d(Qns)/d(T) 436 450 ! ! ------------------------- ! 437 451 srcv(jpr_dqnsdt)%clname = 'O_dQnsdT' 438 IF( TRIM( cn_rcv_dqnsdt) == 'coupled' ) srcv(jpr_dqnsdt)%laction = .TRUE.439 ! 440 ! non solar sensitivity mandatory for ice model441 IF( TRIM( cn_rcv_dqnsdt ) == 'none' .AND. k_ice /= 0) &442 CALL ctl_stop( 'sbc_cpl_init: cn_rcv_dqnsdtmust be coupled in namsbc_cpl namelist' )452 IF( TRIM( sn_rcv_dqnsdt%cldes ) == 'coupled' ) srcv(jpr_dqnsdt)%laction = .TRUE. 453 ! 454 ! non solar sensitivity mandatory for LIM ice model 455 IF( TRIM( sn_rcv_dqnsdt%cldes ) == 'none' .AND. k_ice /= 0 .AND. k_ice /= 4) & 456 CALL ctl_stop( 'sbc_cpl_init: sn_rcv_dqnsdt%cldes must be coupled in namsbc_cpl namelist' ) 443 457 ! non solar sensitivity mandatory for mixed oce-ice solar radiation coupling technique 444 IF( TRIM( cn_rcv_dqnsdt ) == 'none' .AND. TRIM( cn_rcv_qns ) == 'mixed oce-ice' ) &445 CALL ctl_stop( 'sbc_cpl_init: namsbc_cpl namelist mismatch between cn_rcv_qns and cn_rcv_dqnsdt' )458 IF( TRIM( sn_rcv_dqnsdt%cldes ) == 'none' .AND. TRIM( sn_rcv_qns%cldes ) == 'mixed oce-ice' ) & 459 CALL ctl_stop( 'sbc_cpl_init: namsbc_cpl namelist mismatch between sn_rcv_qns%cldes and sn_rcv_dqnsdt%cldes' ) 446 460 ! ! ------------------------- ! 447 461 ! ! Ice Qsr penetration ! … … 456 470 ! ! 10m wind module ! 457 471 ! ! ------------------------- ! 458 srcv(jpr_w10m)%clname = 'O_Wind10' ; IF( TRIM( cn_rcv_w10m) == 'coupled' ) srcv(jpr_w10m)%laction = .TRUE.472 srcv(jpr_w10m)%clname = 'O_Wind10' ; IF( TRIM(sn_rcv_w10m%cldes ) == 'coupled' ) srcv(jpr_w10m)%laction = .TRUE. 459 473 ! 460 474 ! ! ------------------------- ! 461 475 ! ! wind stress module ! 462 476 ! ! ------------------------- ! 463 srcv(jpr_taum)%clname = 'O_TauMod' ; IF( TRIM( cn_rcv_taumod) == 'coupled' ) srcv(jpr_taum)%laction = .TRUE.477 srcv(jpr_taum)%clname = 'O_TauMod' ; IF( TRIM(sn_rcv_taumod%cldes) == 'coupled' ) srcv(jpr_taum)%laction = .TRUE. 464 478 lhftau = srcv(jpr_taum)%laction 465 479 466 #if defined key_cpl_carbon_cycle467 480 ! ! ------------------------- ! 468 481 ! ! Atmospheric CO2 ! 469 482 ! ! ------------------------- ! 470 srcv(jpr_co2 )%clname = 'O_AtmCO2' ; IF( TRIM(cn_rcv_co2 ) == 'coupled' ) srcv(jpr_co2 )%laction = .TRUE. 471 #endif 472 483 srcv(jpr_co2 )%clname = 'O_AtmCO2' ; IF( TRIM(sn_rcv_co2%cldes ) == 'coupled' ) srcv(jpr_co2 )%laction = .TRUE. 484 ! ! ------------------------- ! 485 ! ! topmelt and botmelt ! 486 ! ! ------------------------- ! 487 srcv(jpr_topm )%clname = 'OTopMlt' 488 srcv(jpr_botm )%clname = 'OBotMlt' 489 IF( TRIM(sn_rcv_iceflx%cldes) == 'coupled' ) THEN 490 IF ( TRIM( sn_rcv_iceflx%clcat ) == 'yes' ) THEN 491 srcv(jpr_topm:jpr_botm)%nct = jpl 492 ELSE 493 CALL ctl_stop( 'sbc_cpl_init: sn_rcv_iceflx%clcat should always be set to yes currently' ) 494 ENDIF 495 srcv(jpr_topm:jpr_botm)%laction = .TRUE. 496 ENDIF 497 498 ! Allocate all parts of frcv used for received fields 499 DO jn = 1, jprcv 500 IF ( srcv(jn)%laction ) ALLOCATE( frcv(jn)%z3(jpi,jpj,srcv(jn)%nct) ) 501 END DO 502 ! Allocate taum part of frcv which is used even when not received as coupling field 503 IF ( .NOT. srcv(jpr_taum)%laction ) ALLOCATE( frcv(jpr_taum)%z3(jpi,jpj,srcv(jn)%nct) ) 504 473 505 ! ================================ ! 474 506 ! Define the send interface ! 475 507 ! ================================ ! 476 ! for each field: define the OASIS name (s rcv(:)%clname)477 ! define send or not from the namelist parameters (s rcv(:)%laction)478 ! define the north fold type of lbc (s rcv(:)%nsgn)508 ! for each field: define the OASIS name (ssnd(:)%clname) 509 ! define send or not from the namelist parameters (ssnd(:)%laction) 510 ! define the north fold type of lbc (ssnd(:)%nsgn) 479 511 480 512 ! default definitions of nsnd 481 ssnd(:)%laction = .FALSE. ; ssnd(:)%clgrid = 'T' ; ssnd(:)%nsgn = 1. 513 ssnd(:)%laction = .FALSE. ; ssnd(:)%clgrid = 'T' ; ssnd(:)%nsgn = 1. ; ssnd(:)%nct = 1 482 514 483 515 ! ! ------------------------- ! … … 487 519 ssnd(jps_tice)%clname = 'O_TepIce' 488 520 ssnd(jps_tmix)%clname = 'O_TepMix' 489 SELECT CASE( TRIM( cn_snd_temperature) )521 SELECT CASE( TRIM( sn_snd_temp%cldes ) ) 490 522 CASE( 'oce only' ) ; ssnd( jps_toce )%laction = .TRUE. 491 CASE( 'weighted oce and ice' ) ; ssnd( (/jps_toce, jps_tice/) )%laction = .TRUE. 523 CASE( 'weighted oce and ice' ) 524 ssnd( (/jps_toce, jps_tice/) )%laction = .TRUE. 525 IF ( TRIM( sn_snd_temp%clcat ) == 'yes' ) ssnd(jps_tice)%nct = jpl 492 526 CASE( 'mixed oce-ice' ) ; ssnd( jps_tmix )%laction = .TRUE. 493 CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of cn_snd_temperature' )527 CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_temp%cldes' ) 494 528 END SELECT 495 529 … … 499 533 ssnd(jps_albice)%clname = 'O_AlbIce' 500 534 ssnd(jps_albmix)%clname = 'O_AlbMix' 501 SELECT CASE( TRIM( cn_snd_albedo) )535 SELECT CASE( TRIM( sn_snd_alb%cldes ) ) 502 536 CASE( 'none' ) ! nothing to do 503 537 CASE( 'weighted ice' ) ; ssnd(jps_albice)%laction = .TRUE. 504 538 CASE( 'mixed oce-ice' ) ; ssnd(jps_albmix)%laction = .TRUE. 505 CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of cn_snd_albedo' )539 CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_alb%cldes' ) 506 540 END SELECT 507 541 ! … … 509 543 ! 1. sending mixed oce-ice albedo or 510 544 ! 2. receiving mixed oce-ice solar radiation 511 IF ( TRIM ( cn_snd_albedo ) == 'mixed oce-ice' .OR. TRIM ( cn_rcv_qsr) == 'mixed oce-ice' ) THEN545 IF ( TRIM ( sn_snd_alb%cldes ) == 'mixed oce-ice' .OR. TRIM ( sn_rcv_qsr%cldes ) == 'mixed oce-ice' ) THEN 512 546 CALL albedo_oce( zaos, zacs ) 513 547 ! Due to lack of information on nebulosity : mean clear/overcast sky … … 518 552 ! ! Ice fraction & Thickness ! 519 553 ! ! ------------------------- ! 520 ssnd(jps_fice)%clname = 'OIceFrac' 521 ssnd(jps_hice)%clname = 'O_IceTck' 522 ssnd(jps_hsnw)%clname = 'O_SnwTck' 523 IF( k_ice /= 0 ) ssnd(jps_fice)%laction = .TRUE. ! if ice treated in the ocean (even in climato case) 524 IF( TRIM( cn_snd_thickness ) == 'weighted ice and snow' ) ssnd( (/jps_hice, jps_hsnw/) )%laction = .TRUE. 525 554 ssnd(jps_fice)%clname = 'OIceFrc' 555 ssnd(jps_hice)%clname = 'OIceTck' 556 ssnd(jps_hsnw)%clname = 'OSnwTck' 557 IF( k_ice /= 0 ) THEN 558 ssnd(jps_fice)%laction = .TRUE. ! if ice treated in the ocean (even in climato case) 559 ! Currently no namelist entry to determine sending of multi-category ice fraction so use the thickness entry for now 560 IF ( TRIM( sn_snd_thick%clcat ) == 'yes' ) ssnd(jps_fice)%nct = jpl 561 ENDIF 562 563 SELECT CASE ( TRIM( sn_snd_thick%cldes ) ) 564 CASE ( 'ice and snow' ) 565 ssnd(jps_hice:jps_hsnw)%laction = .TRUE. 566 IF ( TRIM( sn_snd_thick%clcat ) == 'yes' ) THEN 567 ssnd(jps_hice:jps_hsnw)%nct = jpl 568 ELSE 569 IF ( jpl > 1 ) THEN 570 CALL ctl_stop( 'sbc_cpl_init: use weighted ice and snow option for sn_snd_thick%cldes if not exchanging category fields' ) 571 ENDIF 572 ENDIF 573 CASE ( 'weighted ice and snow' ) 574 ssnd(jps_hice:jps_hsnw)%laction = .TRUE. 575 IF ( TRIM( sn_snd_thick%clcat ) == 'yes' ) ssnd(jps_hice:jps_hsnw)%nct = jpl 576 CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_thick%cldes' ) 577 END SELECT 578 526 579 ! ! ------------------------- ! 527 580 ! ! Surface current ! … … 534 587 ssnd(jps_ocx1:jps_ivz1)%nsgn = -1. ! vectors: change of the sign at the north fold 535 588 536 IF( cn_snd_crt(4) /= 'T' ) CALL ctl_stop( 'cn_snd_crt(4) must be equal to T' ) 537 ssnd(jps_ocx1:jps_ivz1)%clgrid = 'T' ! all oce and ice components on the same unique grid 538 589 IF( sn_snd_crt%clvgrd == 'U,V' ) THEN 590 ssnd(jps_ocx1)%clgrid = 'U' ; ssnd(jps_ocy1)%clgrid = 'V' 591 ELSE IF( sn_snd_crt%clvgrd /= 'T' ) THEN 592 CALL ctl_stop( 'sn_snd_crt%clvgrd must be equal to T' ) 593 ssnd(jps_ocx1:jps_ivz1)%clgrid = 'T' ! all oce and ice components on the same unique grid 594 ENDIF 539 595 ssnd(jps_ocx1:jps_ivz1)%laction = .TRUE. ! default: all are send 540 IF( TRIM( cn_snd_crt(2) ) == 'spherical' ) ssnd( (/jps_ocz1, jps_ivz1/) )%laction = .FALSE. 541 SELECT CASE( TRIM( cn_snd_crt(1) ) ) 596 IF( TRIM( sn_snd_crt%clvref ) == 'spherical' ) ssnd( (/jps_ocz1, jps_ivz1/) )%laction = .FALSE. 597 IF( TRIM( sn_snd_crt%clvor ) == 'eastward-northward' ) ssnd(jps_ocx1:jps_ivz1)%nsgn = 1. 598 SELECT CASE( TRIM( sn_snd_crt%cldes ) ) 542 599 CASE( 'none' ) ; ssnd(jps_ocx1:jps_ivz1)%laction = .FALSE. 543 600 CASE( 'oce only' ) ; ssnd(jps_ivx1:jps_ivz1)%laction = .FALSE. 544 601 CASE( 'weighted oce and ice' ) ! nothing to do 545 602 CASE( 'mixed oce-ice' ) ; ssnd(jps_ivx1:jps_ivz1)%laction = .FALSE. 546 CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of cn_snd_crt(1)' )603 CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_crt%cldes' ) 547 604 END SELECT 548 605 549 #if defined key_cpl_carbon_cycle550 606 ! ! ------------------------- ! 551 607 ! ! CO2 flux ! 552 608 ! ! ------------------------- ! 553 ssnd(jps_co2)%clname = 'O_CO2FLX' ; IF( TRIM(cn_snd_co2) == 'coupled' ) ssnd(jps_co2 )%laction = .TRUE. 554 #endif 609 ssnd(jps_co2)%clname = 'O_CO2FLX' ; IF( TRIM(sn_snd_co2%cldes) == 'coupled' ) ssnd(jps_co2 )%laction = .TRUE. 555 610 ! 556 611 ! ================================ ! … … 563 618 & CALL ctl_stop( 'sbc_cpl_init: diurnal cycle reconstruction (ln_dm2dc) needs daily couping for solar radiation' ) 564 619 565 IF( wrk_not_released(2, 3,4) ) CALL ctl_stop('sbc_cpl_init: failed to release workspace arrays') 620 CALL wrk_dealloc( jpi,jpj, zacs, zaos ) 621 ! 622 IF( nn_timing == 1 ) CALL timing_stop('sbc_cpl_init') 566 623 ! 567 624 END SUBROUTINE sbc_cpl_init … … 610 667 !! emp = emps evap. - precip. (- runoffs) (- calving) ('ocean only case) 611 668 !!---------------------------------------------------------------------- 612 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released613 USE wrk_nemo, ONLY: ztx => wrk_2d_1 , zty => wrk_2d_2614 !!615 669 INTEGER, INTENT(in) :: kt ! ocean model time step index 616 670 INTEGER, INTENT(in) :: k_fsbc ! frequency of sbc (-> ice model) computation … … 625 679 REAL(wp) :: zcdrag = 1.5e-3 ! drag coefficient 626 680 REAL(wp) :: zzx, zzy ! temporary variables 681 REAL(wp), POINTER, DIMENSION(:,:) :: ztx, zty 627 682 !!---------------------------------------------------------------------- 628 629 IF( wrk_in_use(2, 1,2) ) THEN630 CALL ctl_stop('sbc_cpl_rcv: requested workspace arrays unavailable') ; RETURN631 ENDIF683 ! 684 IF( nn_timing == 1 ) CALL timing_start('sbc_cpl_rcv') 685 ! 686 CALL wrk_alloc( jpi,jpj, ztx, zty ) 632 687 633 688 IF( kt == nit000 ) CALL sbc_cpl_init( k_ice ) ! initialisation … … 636 691 isec = ( kt - nit000 ) * NINT( rdttra(1) ) ! date of exchanges 637 692 DO jn = 1, jprcv ! received fields sent by the atmosphere 638 IF( srcv(jn)%laction ) CALL cpl_prism_rcv( jn, isec, frcv( :,:,jn), nrcvinfo(jn) )693 IF( srcv(jn)%laction ) CALL cpl_prism_rcv( jn, isec, frcv(jn)%z3, nrcvinfo(jn) ) 639 694 END DO 640 695 … … 642 697 IF( srcv(jpr_otx1)%laction ) THEN ! ocean stress components ! 643 698 ! ! ========================= ! 644 ! define frcv( :,:,jpr_otx1) and frcv(:,:,jpr_oty1): stress at U/V point along model grid699 ! define frcv(jpr_otx1)%z3(:,:,1) and frcv(jpr_oty1)%z3(:,:,1): stress at U/V point along model grid 645 700 ! => need to be done only when we receive the field 646 701 IF( nrcvinfo(jpr_otx1) == OASIS_Rcv ) THEN 647 702 ! 648 IF( TRIM( cn_rcv_tau(2)) == 'cartesian' ) THEN ! 2 components on the sphere703 IF( TRIM( sn_rcv_tau%clvref ) == 'cartesian' ) THEN ! 2 components on the sphere 649 704 ! ! (cartesian to spherical -> 3 to 2 components) 650 705 ! 651 CALL geo2oce( frcv( :,:,jpr_otx1), frcv(:,:,jpr_oty1), frcv(:,:,jpr_otz1), &706 CALL geo2oce( frcv(jpr_otx1)%z3(:,:,1), frcv(jpr_oty1)%z3(:,:,1), frcv(jpr_otz1)%z3(:,:,1), & 652 707 & srcv(jpr_otx1)%clgrid, ztx, zty ) 653 frcv( :,:,jpr_otx1) = ztx(:,:) ! overwrite 1st comp. on the 1st grid654 frcv( :,:,jpr_oty1) = zty(:,:) ! overwrite 2nd comp. on the 1st grid708 frcv(jpr_otx1)%z3(:,:,1) = ztx(:,:) ! overwrite 1st comp. on the 1st grid 709 frcv(jpr_oty1)%z3(:,:,1) = zty(:,:) ! overwrite 2nd comp. on the 1st grid 655 710 ! 656 711 IF( srcv(jpr_otx2)%laction ) THEN 657 CALL geo2oce( frcv( :,:,jpr_otx2), frcv(:,:,jpr_oty2), frcv(:,:,jpr_otz2), &712 CALL geo2oce( frcv(jpr_otx2)%z3(:,:,1), frcv(jpr_oty2)%z3(:,:,1), frcv(jpr_otz2)%z3(:,:,1), & 658 713 & srcv(jpr_otx2)%clgrid, ztx, zty ) 659 frcv( :,:,jpr_otx2) = ztx(:,:) ! overwrite 1st comp. on the 2nd grid660 frcv( :,:,jpr_oty2) = zty(:,:) ! overwrite 2nd comp. on the 2nd grid714 frcv(jpr_otx2)%z3(:,:,1) = ztx(:,:) ! overwrite 1st comp. on the 2nd grid 715 frcv(jpr_oty2)%z3(:,:,1) = zty(:,:) ! overwrite 2nd comp. on the 2nd grid 661 716 ENDIF 662 717 ! 663 718 ENDIF 664 719 ! 665 IF( TRIM( cn_rcv_tau(3)) == 'eastward-northward' ) THEN ! 2 components oriented along the local grid720 IF( TRIM( sn_rcv_tau%clvor ) == 'eastward-northward' ) THEN ! 2 components oriented along the local grid 666 721 ! ! (geographical to local grid -> rotate the components) 667 CALL rot_rep( frcv( :,:,jpr_otx1), frcv(:,:,jpr_oty1), srcv(jpr_otx1)%clgrid, 'en->i', ztx )668 frcv( :,:,jpr_otx1) = ztx(:,:) ! overwrite 1st component on the 1st grid722 CALL rot_rep( frcv(jpr_otx1)%z3(:,:,1), frcv(jpr_oty1)%z3(:,:,1), srcv(jpr_otx1)%clgrid, 'en->i', ztx ) 723 frcv(jpr_otx1)%z3(:,:,1) = ztx(:,:) ! overwrite 1st component on the 1st grid 669 724 IF( srcv(jpr_otx2)%laction ) THEN 670 CALL rot_rep( frcv( :,:,jpr_otx2), frcv(:,:,jpr_oty2), srcv(jpr_otx2)%clgrid, 'en->j', zty )671 ELSE 672 CALL rot_rep( frcv( :,:,jpr_otx1), frcv(:,:,jpr_oty1), srcv(jpr_otx1)%clgrid, 'en->j', zty )725 CALL rot_rep( frcv(jpr_otx2)%z3(:,:,1), frcv(jpr_oty2)%z3(:,:,1), srcv(jpr_otx2)%clgrid, 'en->j', zty ) 726 ELSE 727 CALL rot_rep( frcv(jpr_otx1)%z3(:,:,1), frcv(jpr_oty1)%z3(:,:,1), srcv(jpr_otx1)%clgrid, 'en->j', zty ) 673 728 ENDIF 674 frcv( :,:,jpr_oty1) = zty(:,:) ! overwrite 2nd component on the 2nd grid729 frcv(jpr_oty1)%z3(:,:,1) = zty(:,:) ! overwrite 2nd component on the 2nd grid 675 730 ENDIF 676 731 ! … … 678 733 DO jj = 2, jpjm1 ! T ==> (U,V) 679 734 DO ji = fs_2, fs_jpim1 ! vector opt. 680 frcv(j i,jj,jpr_otx1) = 0.5 * ( frcv(ji+1,jj ,jpr_otx1) + frcv(ji,jj,jpr_otx1) )681 frcv(j i,jj,jpr_oty1) = 0.5 * ( frcv(ji ,jj+1,jpr_oty1) + frcv(ji,jj,jpr_oty1) )735 frcv(jpr_otx1)%z3(ji,jj,1) = 0.5 * ( frcv(jpr_otx1)%z3(ji+1,jj ,1) + frcv(jpr_otx1)%z3(ji,jj,1) ) 736 frcv(jpr_oty1)%z3(ji,jj,1) = 0.5 * ( frcv(jpr_oty1)%z3(ji ,jj+1,1) + frcv(jpr_oty1)%z3(ji,jj,1) ) 682 737 END DO 683 738 END DO 684 CALL lbc_lnk( frcv( :,:,jpr_otx1), 'U', -1. ) ; CALL lbc_lnk( frcv(:,:,jpr_oty1), 'V', -1. )739 CALL lbc_lnk( frcv(jpr_otx1)%z3(:,:,1), 'U', -1. ) ; CALL lbc_lnk( frcv(jpr_oty1)%z3(:,:,1), 'V', -1. ) 685 740 ENDIF 686 741 llnewtx = .TRUE. … … 691 746 ELSE ! No dynamical coupling ! 692 747 ! ! ========================= ! 693 frcv( :,:,jpr_otx1) = 0.e0 ! here simply set to zero694 frcv( :,:,jpr_oty1) = 0.e0 ! an external read in a file can be added instead748 frcv(jpr_otx1)%z3(:,:,1) = 0.e0 ! here simply set to zero 749 frcv(jpr_oty1)%z3(:,:,1) = 0.e0 ! an external read in a file can be added instead 695 750 llnewtx = .TRUE. 696 751 ! … … 708 763 !CDIR NOVERRCHK 709 764 DO ji = fs_2, fs_jpim1 ! vect. opt. 710 zzx = frcv(j i-1,jj ,jpr_otx1) + frcv(ji,jj,jpr_otx1)711 zzy = frcv(j i ,jj-1,jpr_oty1) + frcv(ji,jj,jpr_oty1)712 frcv(j i,jj,jpr_taum) = 0.5 * SQRT( zzx * zzx + zzy * zzy )765 zzx = frcv(jpr_otx1)%z3(ji-1,jj ,1) + frcv(jpr_otx1)%z3(ji,jj,1) 766 zzy = frcv(jpr_oty1)%z3(ji ,jj-1,1) + frcv(jpr_oty1)%z3(ji,jj,1) 767 frcv(jpr_taum)%z3(ji,jj,1) = 0.5 * SQRT( zzx * zzx + zzy * zzy ) 713 768 END DO 714 769 END DO 715 CALL lbc_lnk( frcv( :,:,jpr_taum), 'T', 1. )770 CALL lbc_lnk( frcv(jpr_taum)%z3(:,:,1), 'T', 1. ) 716 771 llnewtau = .TRUE. 717 772 ELSE … … 722 777 ! Stress module can be negative when received (interpolation problem) 723 778 IF( llnewtau ) THEN 724 DO jj = 1, jpj 725 DO ji = 1, jpi 726 frcv(ji,jj,jpr_taum) = MAX( 0.0e0, frcv(ji,jj,jpr_taum) ) 727 END DO 728 END DO 779 frcv(jpr_taum)%z3(:,:,1) = MAX( 0.0e0, frcv(jpr_taum)%z3(:,:,1) ) 729 780 ENDIF 730 781 ENDIF … … 742 793 !CDIR NOVERRCHK 743 794 DO ji = 1, jpi 744 frcv(ji,jj,jpr_w10m) = SQRT( frcv(ji,jj,jpr_taum) * zcoef )795 wndm(ji,jj) = SQRT( frcv(jpr_taum)%z3(ji,jj,1) * zcoef ) 745 796 END DO 746 797 END DO 747 798 ENDIF 748 ENDIF 749 750 ! u(v)tau and taum will be modified by ice model (wndm will be changed by PISCES) 799 ELSE 800 IF ( nrcvinfo(jpr_w10m) == OASIS_Rcv ) wndm(:,:) = frcv(jpr_w10m)%z3(:,:,1) 801 ENDIF 802 803 ! u(v)tau and taum will be modified by ice model 751 804 ! -> need to be reset before each call of the ice/fsbc 752 805 IF( MOD( kt-1, k_fsbc ) == 0 ) THEN 753 806 ! 754 utau(:,:) = frcv(:,:,jpr_otx1) 755 vtau(:,:) = frcv(:,:,jpr_oty1) 756 taum(:,:) = frcv(:,:,jpr_taum) 757 wndm(:,:) = frcv(:,:,jpr_w10m) 807 utau(:,:) = frcv(jpr_otx1)%z3(:,:,1) 808 vtau(:,:) = frcv(jpr_oty1)%z3(:,:,1) 809 taum(:,:) = frcv(jpr_taum)%z3(:,:,1) 758 810 CALL iom_put( "taum_oce", taum ) ! output wind stress module 759 811 ! 760 812 ENDIF 813 814 #if defined key_cpl_carbon_cycle 815 ! ! atmosph. CO2 (ppm) 816 IF( srcv(jpr_co2)%laction ) atm_co2(:,:) = frcv(jpr_co2)%z3(:,:,1) 817 #endif 818 761 819 ! ! ========================= ! 762 820 IF( k_ice <= 1 ) THEN ! heat & freshwater fluxes ! (Ocean only case) … … 764 822 ! 765 823 ! ! non solar heat flux over the ocean (qns) 766 IF( srcv(jpr_qnsoce)%laction ) qns(:,:) = frcv( :,:,jpr_qnsoce)767 IF( srcv(jpr_qnsmix)%laction ) qns(:,:) = frcv( :,:,jpr_qnsmix)824 IF( srcv(jpr_qnsoce)%laction ) qns(:,:) = frcv(jpr_qnsoce)%z3(:,:,1) 825 IF( srcv(jpr_qnsmix)%laction ) qns(:,:) = frcv(jpr_qnsmix)%z3(:,:,1) 768 826 ! add the latent heat of solid precip. melting 769 IF( srcv(jpr_snow )%laction ) qns(:,:) = qns(:,:) - frcv( :,:,jpr_snow) * lfus827 IF( srcv(jpr_snow )%laction ) qns(:,:) = qns(:,:) - frcv(jpr_snow)%z3(:,:,1) * lfus 770 828 771 829 ! ! solar flux over the ocean (qsr) 772 IF( srcv(jpr_qsroce)%laction ) qsr(:,:) = frcv( :,:,jpr_qsroce)773 IF( srcv(jpr_qsrmix)%laction ) qsr(:,:) = frcv( :,:,jpr_qsrmix)830 IF( srcv(jpr_qsroce)%laction ) qsr(:,:) = frcv(jpr_qsroce)%z3(:,:,1) 831 IF( srcv(jpr_qsrmix)%laction ) qsr(:,:) = frcv(jpr_qsrmix)%z3(:,:,1) 774 832 IF( ln_dm2dc ) qsr(:,:) = sbc_dcy( qsr ) ! modify qsr to include the diurnal cycle 775 833 ! 776 834 ! ! total freshwater fluxes over the ocean (emp, emps) 777 SELECT CASE( TRIM( cn_rcv_emp) ) ! evaporation - precipitation835 SELECT CASE( TRIM( sn_rcv_emp%cldes ) ) ! evaporation - precipitation 778 836 CASE( 'conservative' ) 779 emp(:,:) = frcv( :,:,jpr_tevp) - ( frcv(:,:,jpr_rain) + frcv(:,:,jpr_snow) )837 emp(:,:) = frcv(jpr_tevp)%z3(:,:,1) - ( frcv(jpr_rain)%z3(:,:,1) + frcv(jpr_snow)%z3(:,:,1) ) 780 838 CASE( 'oce only', 'oce and ice' ) 781 emp(:,:) = frcv( :,:,jpr_oemp)839 emp(:,:) = frcv(jpr_oemp)%z3(:,:,1) 782 840 CASE default 783 CALL ctl_stop( 'sbc_cpl_rcv: wrong definition of cn_rcv_emp' )841 CALL ctl_stop( 'sbc_cpl_rcv: wrong definition of sn_rcv_emp%cldes' ) 784 842 END SELECT 785 843 ! 786 844 ! ! runoffs and calving (added in emp) 787 IF( srcv(jpr_rnf)%laction ) emp(:,:) = emp(:,:) - frcv( :,:,jpr_rnf)788 IF( srcv(jpr_cal)%laction ) emp(:,:) = emp(:,:) - frcv( :,:,jpr_cal)845 IF( srcv(jpr_rnf)%laction ) emp(:,:) = emp(:,:) - frcv(jpr_rnf)%z3(:,:,1) 846 IF( srcv(jpr_cal)%laction ) emp(:,:) = emp(:,:) - frcv(jpr_cal)%z3(:,:,1) 789 847 ! 790 848 !!gm : this seems to be internal cooking, not sure to need that in a generic interface 791 849 !!gm at least should be optional... 792 !! IF( TRIM( cn_rcv_rnf) == 'coupled' ) THEN ! add to the total freshwater budget850 !! IF( TRIM( sn_rcv_rnf%cldes ) == 'coupled' ) THEN ! add to the total freshwater budget 793 851 !! ! remove negative runoff 794 !! zcumulpos = SUM( MAX( frcv( :,:,jpr_rnf), 0.e0 ) * e1t(:,:) * e2t(:,:) * tmask_i(:,:) )795 !! zcumulneg = SUM( MIN( frcv( :,:,jpr_rnf), 0.e0 ) * e1t(:,:) * e2t(:,:) * tmask_i(:,:) )852 !! zcumulpos = SUM( MAX( frcv(jpr_rnf)%z3(:,:,1), 0.e0 ) * e1t(:,:) * e2t(:,:) * tmask_i(:,:) ) 853 !! zcumulneg = SUM( MIN( frcv(jpr_rnf)%z3(:,:,1), 0.e0 ) * e1t(:,:) * e2t(:,:) * tmask_i(:,:) ) 796 854 !! IF( lk_mpp ) CALL mpp_sum( zcumulpos ) ! sum over the global domain 797 855 !! IF( lk_mpp ) CALL mpp_sum( zcumulneg ) 798 856 !! IF( zcumulpos /= 0. ) THEN ! distribute negative runoff on positive runoff grid points 799 857 !! zcumulneg = 1.e0 + zcumulneg / zcumulpos 800 !! frcv( :,:,jpr_rnf) = MAX( frcv(:,:,jpr_rnf), 0.e0 ) * zcumulneg858 !! frcv(jpr_rnf)%z3(:,:,1) = MAX( frcv(jpr_rnf)%z3(:,:,1), 0.e0 ) * zcumulneg 801 859 !! ENDIF 802 860 !! ! add runoff to e-p 803 !! emp(:,:) = emp(:,:) - frcv( :,:,jpr_rnf)861 !! emp(:,:) = emp(:,:) - frcv(jpr_rnf)%z3(:,:,1) 804 862 !! ENDIF 805 863 !!gm end of internal cooking … … 807 865 emps(:,:) = emp(:,:) ! concentration/dilution = emp 808 866 809 ! ! 10 m wind speed 810 IF( srcv(jpr_w10m)%laction ) wndm(:,:) = frcv(:,:,jpr_w10m) 811 ! 812 #if defined key_cpl_carbon_cycle 813 ! ! atmosph. CO2 (ppm) 814 IF( srcv(jpr_co2)%laction ) atm_co2(:,:) = frcv(:,:,jpr_co2) 815 #endif 816 817 ENDIF 818 ! 819 IF( wrk_not_released(2, 1,2) ) CALL ctl_stop('sbc_cpl_rcv: failed to release workspace arrays') 867 ENDIF 868 ! 869 CALL wrk_dealloc( jpi,jpj, ztx, zty ) 870 ! 871 IF( nn_timing == 1 ) CALL timing_stop('sbc_cpl_rcv') 820 872 ! 821 873 END SUBROUTINE sbc_cpl_rcv … … 855 907 !! ** Action : return ptau_i, ptau_j, the stress over the ice at cp_ice_msh point 856 908 !!---------------------------------------------------------------------- 857 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released858 USE wrk_nemo, ONLY: ztx => wrk_2d_1 , zty => wrk_2d_2859 !!860 909 REAL(wp), INTENT(out), DIMENSION(:,:) :: p_taui ! i- & j-components of atmos-ice stress [N/m2] 861 910 REAL(wp), INTENT(out), DIMENSION(:,:) :: p_tauj ! at I-point (B-grid) or U & V-point (C-grid) … … 863 912 INTEGER :: ji, jj ! dummy loop indices 864 913 INTEGER :: itx ! index of taux over ice 914 REAL(wp), POINTER, DIMENSION(:,:) :: ztx, zty 865 915 !!---------------------------------------------------------------------- 866 867 IF( wrk_in_use(2, 1,2) ) THEN868 CALL ctl_stop('sbc_cpl_ice_tau: requested workspace arrays unavailable') ; RETURN869 ENDIF916 ! 917 IF( nn_timing == 1 ) CALL timing_start('sbc_cpl_ice_tau') 918 ! 919 CALL wrk_alloc( jpi,jpj, ztx, zty ) 870 920 871 921 IF( srcv(jpr_itx1)%laction ) THEN ; itx = jpr_itx1 … … 880 930 ! ! ======================= ! 881 931 ! 882 IF( TRIM( cn_rcv_tau(2)) == 'cartesian' ) THEN ! 2 components on the sphere932 IF( TRIM( sn_rcv_tau%clvref ) == 'cartesian' ) THEN ! 2 components on the sphere 883 933 ! ! (cartesian to spherical -> 3 to 2 components) 884 CALL geo2oce( frcv(:,:,jpr_itx1), frcv(:,:,jpr_ity1), frcv(:,:,jpr_itz1), &934 CALL geo2oce( frcv(jpr_itx1)%z3(:,:,1), frcv(jpr_ity1)%z3(:,:,1), frcv(jpr_itz1)%z3(:,:,1), & 885 935 & srcv(jpr_itx1)%clgrid, ztx, zty ) 886 frcv( :,:,jpr_itx1) = ztx(:,:) ! overwrite 1st comp. on the 1st grid887 frcv( :,:,jpr_itx1) = zty(:,:) ! overwrite 2nd comp. on the 1st grid936 frcv(jpr_itx1)%z3(:,:,1) = ztx(:,:) ! overwrite 1st comp. on the 1st grid 937 frcv(jpr_ity1)%z3(:,:,1) = zty(:,:) ! overwrite 2nd comp. on the 1st grid 888 938 ! 889 939 IF( srcv(jpr_itx2)%laction ) THEN 890 CALL geo2oce( frcv( :,:,jpr_itx2), frcv(:,:,jpr_ity2), frcv(:,:,jpr_itz2), &940 CALL geo2oce( frcv(jpr_itx2)%z3(:,:,1), frcv(jpr_ity2)%z3(:,:,1), frcv(jpr_itz2)%z3(:,:,1), & 891 941 & srcv(jpr_itx2)%clgrid, ztx, zty ) 892 frcv( :,:,jpr_itx2) = ztx(:,:) ! overwrite 1st comp. on the 2nd grid893 frcv( :,:,jpr_ity2) = zty(:,:) ! overwrite 2nd comp. on the 2nd grid942 frcv(jpr_itx2)%z3(:,:,1) = ztx(:,:) ! overwrite 1st comp. on the 2nd grid 943 frcv(jpr_ity2)%z3(:,:,1) = zty(:,:) ! overwrite 2nd comp. on the 2nd grid 894 944 ENDIF 895 945 ! 896 946 ENDIF 897 947 ! 898 IF( TRIM( cn_rcv_tau(3)) == 'eastward-northward' ) THEN ! 2 components oriented along the local grid948 IF( TRIM( sn_rcv_tau%clvor ) == 'eastward-northward' ) THEN ! 2 components oriented along the local grid 899 949 ! ! (geographical to local grid -> rotate the components) 900 CALL rot_rep( frcv( :,:,jpr_itx1), frcv(:,:,jpr_ity1), srcv(jpr_itx1)%clgrid, 'en->i', ztx )901 frcv( :,:,jpr_itx1) = ztx(:,:) ! overwrite 1st component on the 1st grid950 CALL rot_rep( frcv(jpr_itx1)%z3(:,:,1), frcv(jpr_ity1)%z3(:,:,1), srcv(jpr_itx1)%clgrid, 'en->i', ztx ) 951 frcv(jpr_itx1)%z3(:,:,1) = ztx(:,:) ! overwrite 1st component on the 1st grid 902 952 IF( srcv(jpr_itx2)%laction ) THEN 903 CALL rot_rep( frcv( :,:,jpr_itx2), frcv(:,:,jpr_ity2), srcv(jpr_itx2)%clgrid, 'en->j', zty )953 CALL rot_rep( frcv(jpr_itx2)%z3(:,:,1), frcv(jpr_ity2)%z3(:,:,1), srcv(jpr_itx2)%clgrid, 'en->j', zty ) 904 954 ELSE 905 CALL rot_rep( frcv( :,:,jpr_itx1), frcv(:,:,jpr_ity1), srcv(jpr_itx1)%clgrid, 'en->j', zty )955 CALL rot_rep( frcv(jpr_itx1)%z3(:,:,1), frcv(jpr_ity1)%z3(:,:,1), srcv(jpr_itx1)%clgrid, 'en->j', zty ) 906 956 ENDIF 907 frcv( :,:,jpr_ity1) = zty(:,:) ! overwrite 2nd component on the 1st grid957 frcv(jpr_ity1)%z3(:,:,1) = zty(:,:) ! overwrite 2nd component on the 1st grid 908 958 ENDIF 909 959 ! ! ======================= ! 910 960 ELSE ! use ocean stress ! 911 961 ! ! ======================= ! 912 frcv( :,:,jpr_itx1) = frcv(:,:,jpr_otx1)913 frcv( :,:,jpr_ity1) = frcv(:,:,jpr_oty1)962 frcv(jpr_itx1)%z3(:,:,1) = frcv(jpr_otx1)%z3(:,:,1) 963 frcv(jpr_ity1)%z3(:,:,1) = frcv(jpr_oty1)%z3(:,:,1) 914 964 ! 915 965 ENDIF … … 934 984 DO jj = 2, jpjm1 ! (U,V) ==> I 935 985 DO ji = 2, jpim1 ! NO vector opt. 936 p_taui(ji,jj) = 0.5 * ( frcv(j i-1,jj ,jpr_itx1) + frcv(ji-1,jj-1,jpr_itx1) )937 p_tauj(ji,jj) = 0.5 * ( frcv(j i ,jj-1,jpr_ity1) + frcv(ji-1,jj-1,jpr_ity1) )986 p_taui(ji,jj) = 0.5 * ( frcv(jpr_itx1)%z3(ji-1,jj ,1) + frcv(jpr_itx1)%z3(ji-1,jj-1,1) ) 987 p_tauj(ji,jj) = 0.5 * ( frcv(jpr_ity1)%z3(ji ,jj-1,1) + frcv(jpr_ity1)%z3(ji-1,jj-1,1) ) 938 988 END DO 939 989 END DO … … 941 991 DO jj = 2, jpjm1 ! F ==> I 942 992 DO ji = 2, jpim1 ! NO vector opt. 943 p_taui(ji,jj) = frcv(j i-1,jj-1,jpr_itx1)944 p_tauj(ji,jj) = frcv(j i-1,jj-1,jpr_ity1)993 p_taui(ji,jj) = frcv(jpr_itx1)%z3(ji-1,jj-1,1) 994 p_tauj(ji,jj) = frcv(jpr_ity1)%z3(ji-1,jj-1,1) 945 995 END DO 946 996 END DO … … 948 998 DO jj = 2, jpjm1 ! T ==> I 949 999 DO ji = 2, jpim1 ! NO vector opt. 950 p_taui(ji,jj) = 0.25 * ( frcv(j i,jj ,jpr_itx1) + frcv(ji-1,jj ,jpr_itx1) &951 & + frcv(j i,jj-1,jpr_itx1) + frcv(ji-1,jj-1,jpr_itx1) )952 p_tauj(ji,jj) = 0.25 * ( frcv(j i,jj ,jpr_ity1) + frcv(ji-1,jj ,jpr_ity1) &953 & + frcv(j i,jj-1,jpr_ity1) + frcv(ji-1,jj-1,jpr_ity1) )1000 p_taui(ji,jj) = 0.25 * ( frcv(jpr_itx1)%z3(ji,jj ,1) + frcv(jpr_itx1)%z3(ji-1,jj ,1) & 1001 & + frcv(jpr_itx1)%z3(ji,jj-1,1) + frcv(jpr_itx1)%z3(ji-1,jj-1,1) ) 1002 p_tauj(ji,jj) = 0.25 * ( frcv(jpr_ity1)%z3(ji,jj ,1) + frcv(jpr_ity1)%z3(ji-1,jj ,1) & 1003 & + frcv(jpr_oty1)%z3(ji,jj-1,1) + frcv(jpr_ity1)%z3(ji-1,jj-1,1) ) 954 1004 END DO 955 1005 END DO 956 1006 CASE( 'I' ) 957 p_taui(:,:) = frcv( :,:,jpr_itx1) ! I ==> I958 p_tauj(:,:) = frcv( :,:,jpr_ity1)1007 p_taui(:,:) = frcv(jpr_itx1)%z3(:,:,1) ! I ==> I 1008 p_tauj(:,:) = frcv(jpr_ity1)%z3(:,:,1) 959 1009 END SELECT 960 1010 IF( srcv(jpr_itx1)%clgrid /= 'I' ) THEN … … 967 1017 DO jj = 2, jpjm1 ! (U,V) ==> F 968 1018 DO ji = fs_2, fs_jpim1 ! vector opt. 969 p_taui(ji,jj) = 0.5 * ( frcv(j i,jj,jpr_itx1) + frcv(ji ,jj+1,jpr_itx1) )970 p_tauj(ji,jj) = 0.5 * ( frcv(j i,jj,jpr_ity1) + frcv(ji+1,jj ,jpr_ity1) )1019 p_taui(ji,jj) = 0.5 * ( frcv(jpr_itx1)%z3(ji,jj,1) + frcv(jpr_itx1)%z3(ji ,jj+1,1) ) 1020 p_tauj(ji,jj) = 0.5 * ( frcv(jpr_ity1)%z3(ji,jj,1) + frcv(jpr_ity1)%z3(ji+1,jj ,1) ) 971 1021 END DO 972 1022 END DO … … 974 1024 DO jj = 2, jpjm1 ! I ==> F 975 1025 DO ji = 2, jpim1 ! NO vector opt. 976 p_taui(ji,jj) = frcv(j i+1,jj+1,jpr_itx1)977 p_tauj(ji,jj) = frcv(j i+1,jj+1,jpr_ity1)1026 p_taui(ji,jj) = frcv(jpr_itx1)%z3(ji+1,jj+1,1) 1027 p_tauj(ji,jj) = frcv(jpr_ity1)%z3(ji+1,jj+1,1) 978 1028 END DO 979 1029 END DO … … 981 1031 DO jj = 2, jpjm1 ! T ==> F 982 1032 DO ji = 2, jpim1 ! NO vector opt. 983 p_taui(ji,jj) = 0.25 * ( frcv(j i,jj ,jpr_itx1) + frcv(ji+1,jj ,jpr_itx1) &984 & + frcv(j i,jj+1,jpr_itx1) + frcv(ji+1,jj+1,jpr_itx1) )985 p_tauj(ji,jj) = 0.25 * ( frcv(j i,jj ,jpr_ity1) + frcv(ji+1,jj ,jpr_ity1) &986 & + frcv(j i,jj+1,jpr_ity1) + frcv(ji+1,jj+1,jpr_ity1) )1033 p_taui(ji,jj) = 0.25 * ( frcv(jpr_itx1)%z3(ji,jj ,1) + frcv(jpr_itx1)%z3(ji+1,jj ,1) & 1034 & + frcv(jpr_itx1)%z3(ji,jj+1,1) + frcv(jpr_itx1)%z3(ji+1,jj+1,1) ) 1035 p_tauj(ji,jj) = 0.25 * ( frcv(jpr_ity1)%z3(ji,jj ,1) + frcv(jpr_ity1)%z3(ji+1,jj ,1) & 1036 & + frcv(jpr_ity1)%z3(ji,jj+1,1) + frcv(jpr_ity1)%z3(ji+1,jj+1,1) ) 987 1037 END DO 988 1038 END DO 989 1039 CASE( 'F' ) 990 p_taui(:,:) = frcv( :,:,jpr_itx1) ! F ==> F991 p_tauj(:,:) = frcv( :,:,jpr_ity1)1040 p_taui(:,:) = frcv(jpr_itx1)%z3(:,:,1) ! F ==> F 1041 p_tauj(:,:) = frcv(jpr_ity1)%z3(:,:,1) 992 1042 END SELECT 993 1043 IF( srcv(jpr_itx1)%clgrid /= 'F' ) THEN … … 998 1048 SELECT CASE ( srcv(jpr_itx1)%clgrid ) 999 1049 CASE( 'U' ) 1000 p_taui(:,:) = frcv( :,:,jpr_itx1) ! (U,V) ==> (U,V)1001 p_tauj(:,:) = frcv( :,:,jpr_ity1)1050 p_taui(:,:) = frcv(jpr_itx1)%z3(:,:,1) ! (U,V) ==> (U,V) 1051 p_tauj(:,:) = frcv(jpr_ity1)%z3(:,:,1) 1002 1052 CASE( 'F' ) 1003 1053 DO jj = 2, jpjm1 ! F ==> (U,V) 1004 1054 DO ji = fs_2, fs_jpim1 ! vector opt. 1005 p_taui(ji,jj) = 0.5 * ( frcv(j i,jj,jpr_itx1) + frcv(ji ,jj-1,jpr_itx1) )1006 p_tauj(ji,jj) = 0.5 * ( frcv(j i,jj,jpr_ity1) + frcv(ji-1,jj ,jpr_ity1) )1055 p_taui(ji,jj) = 0.5 * ( frcv(jpr_itx1)%z3(ji,jj,1) + frcv(jpr_itx1)%z3(ji ,jj-1,1) ) 1056 p_tauj(ji,jj) = 0.5 * ( frcv(jpr_ity1)%z3(jj,jj,1) + frcv(jpr_ity1)%z3(ji-1,jj ,1) ) 1007 1057 END DO 1008 1058 END DO … … 1010 1060 DO jj = 2, jpjm1 ! T ==> (U,V) 1011 1061 DO ji = fs_2, fs_jpim1 ! vector opt. 1012 p_taui(ji,jj) = 0.5 * ( frcv(j i+1,jj ,jpr_itx1) + frcv(ji,jj,jpr_itx1) )1013 p_tauj(ji,jj) = 0.5 * ( frcv(j i ,jj+1,jpr_ity1) + frcv(ji,jj,jpr_ity1) )1062 p_taui(ji,jj) = 0.5 * ( frcv(jpr_itx1)%z3(ji+1,jj ,1) + frcv(jpr_itx1)%z3(ji,jj,1) ) 1063 p_tauj(ji,jj) = 0.5 * ( frcv(jpr_ity1)%z3(ji ,jj+1,1) + frcv(jpr_ity1)%z3(ji,jj,1) ) 1014 1064 END DO 1015 1065 END DO … … 1017 1067 DO jj = 2, jpjm1 ! I ==> (U,V) 1018 1068 DO ji = 2, jpim1 ! NO vector opt. 1019 p_taui(ji,jj) = 0.5 * ( frcv(j i+1,jj+1,jpr_itx1) + frcv(ji+1,jj ,jpr_itx1) )1020 p_tauj(ji,jj) = 0.5 * ( frcv(j i+1,jj+1,jpr_ity1) + frcv(ji ,jj+1,jpr_ity1) )1069 p_taui(ji,jj) = 0.5 * ( frcv(jpr_itx1)%z3(ji+1,jj+1,1) + frcv(jpr_itx1)%z3(ji+1,jj ,1) ) 1070 p_tauj(ji,jj) = 0.5 * ( frcv(jpr_ity1)%z3(ji+1,jj+1,1) + frcv(jpr_ity1)%z3(ji ,jj+1,1) ) 1021 1071 END DO 1022 1072 END DO … … 1027 1077 END SELECT 1028 1078 1029 !!gm Should be useless as sbc_cpl_ice_tau only called at coupled frequency1030 ! The receive stress are transformed such that in all case frcv(:,:,jpr_itx1), frcv(:,:,jpr_ity1)1031 ! become the i-component and j-component of the stress at the right grid point1032 !!gm frcv(:,:,jpr_itx1) = p_taui(:,:)1033 !!gm frcv(:,:,jpr_ity1) = p_tauj(:,:)1034 !!gm1035 1079 ENDIF 1036 1080 ! 1037 IF( wrk_not_released(2, 1,2) ) CALL ctl_stop('sbc_cpl_ice_tau: failed to release workspace arrays') 1081 CALL wrk_dealloc( jpi,jpj, ztx, zty ) 1082 ! 1083 IF( nn_timing == 1 ) CALL timing_stop('sbc_cpl_ice_tau') 1038 1084 ! 1039 1085 END SUBROUTINE sbc_cpl_ice_tau 1040 1086 1041 1087 1042 SUBROUTINE sbc_cpl_ice_flx( p_frld , & 1043 & pqns_tot, pqns_ice, pqsr_tot , pqsr_ice, & 1044 & pemp_tot, pemp_ice, pdqns_ice, psprecip, & 1045 & palbi , psst , pist ) 1088 SUBROUTINE sbc_cpl_ice_flx( p_frld , palbi , psst , pist ) 1046 1089 !!---------------------------------------------------------------------- 1047 !! *** ROUTINE sbc_cpl_ice_flx _rcv***1090 !! *** ROUTINE sbc_cpl_ice_flx *** 1048 1091 !! 1049 1092 !! ** Purpose : provide the heat and freshwater fluxes of the … … 1066 1109 !! the atmosphere 1067 1110 !! 1068 !! N.B. - fields over sea-ice are passed in argument so that1069 !! the module can be compile without sea-ice.1070 1111 !! - the fluxes have been separated from the stress as 1071 1112 !! (a) they are updated at each ice time step compare to … … 1078 1119 !! 1079 1120 !! ** Action : update at each nf_ice time step: 1080 !! pqns_tot, pqsr_tot non-solar and solar total heat fluxes1081 !! pqns_ice, pqsr_ice non-solar and solar heat fluxes over the ice1082 !! pemp_tot total evaporation - precipitation(liquid and solid) (-runoff)(-calving)1083 !! pemp_ice ice sublimation - solid precipitation over the ice1084 !! pdqns_ice d(non-solar heat flux)/d(Temperature) over the ice1121 !! qns_tot, qsr_tot non-solar and solar total heat fluxes 1122 !! qns_ice, qsr_ice non-solar and solar heat fluxes over the ice 1123 !! emp_tot total evaporation - precipitation(liquid and solid) (-runoff)(-calving) 1124 !! emp_ice ice sublimation - solid precipitation over the ice 1125 !! dqns_ice d(non-solar heat flux)/d(Temperature) over the ice 1085 1126 !! sprecip solid precipitation over the ocean 1086 1127 !!---------------------------------------------------------------------- 1087 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released 1088 USE wrk_nemo, ONLY: zcptn => wrk_2d_1 ! rcp * tn(:,:,1) 1089 USE wrk_nemo, ONLY: ztmp => wrk_2d_2 ! temporary array 1090 USE wrk_nemo, ONLY: zsnow => wrk_2d_3 ! snow precipitation 1091 USE wrk_nemo, ONLY: zicefr => wrk_3d_4 ! ice fraction 1092 !! 1093 REAL(wp), INTENT(in ), DIMENSION(:,:,:) :: p_frld ! lead fraction [0 to 1] 1094 REAL(wp), INTENT( out), DIMENSION(:,: ) :: pqns_tot ! total non solar heat flux [W/m2] 1095 REAL(wp), INTENT( out), DIMENSION(:,:,:) :: pqns_ice ! ice non solar heat flux [W/m2] 1096 REAL(wp), INTENT( out), DIMENSION(:,: ) :: pqsr_tot ! total solar heat flux [W/m2] 1097 REAL(wp), INTENT( out), DIMENSION(:,:,:) :: pqsr_ice ! ice solar heat flux [W/m2] 1098 REAL(wp), INTENT( out), DIMENSION(:,: ) :: pemp_tot ! total freshwater budget [Kg/m2/s] 1099 REAL(wp), INTENT( out), DIMENSION(:,: ) :: pemp_ice ! solid freshwater budget over ice [Kg/m2/s] 1100 REAL(wp), INTENT( out), DIMENSION(:,: ) :: psprecip ! Net solid precipitation (=emp_ice) [Kg/m2/s] 1101 REAL(wp), INTENT( out), DIMENSION(:,:,:) :: pdqns_ice ! d(Q non solar)/d(Temperature) over ice 1128 REAL(wp), INTENT(in ), DIMENSION(:,:) :: p_frld ! lead fraction [0 to 1] 1102 1129 ! optional arguments, used only in 'mixed oce-ice' case 1103 1130 REAL(wp), INTENT(in ), DIMENSION(:,:,:), OPTIONAL :: palbi ! ice albedo 1104 1131 REAL(wp), INTENT(in ), DIMENSION(:,: ), OPTIONAL :: psst ! sea surface temperature [Celcius] 1105 1132 REAL(wp), INTENT(in ), DIMENSION(:,:,:), OPTIONAL :: pist ! ice surface temperature [Kelvin] 1106 !! 1107 INTEGER :: ji, jj ! dummy loop indices 1108 INTEGER :: isec, info ! temporary integer 1109 REAL(wp):: zcoef, ztsurf ! temporary scalar 1133 ! 1134 INTEGER :: jl ! dummy loop index 1135 REAL(wp), POINTER, DIMENSION(:,:) :: zcptn, ztmp, zicefr 1110 1136 !!---------------------------------------------------------------------- 1111 1112 IF( wrk_in_use(2, 1,2,3) .OR. wrk_in_use(3, 4) ) THEN1113 CALL ctl_stop('sbc_cpl_ice_flx: requested workspace arrays unavailable') ; RETURN1114 ENDIF1115 1116 zicefr(:,: ,1) = 1.- p_frld(:,:,1)1117 IF( lk_diaar5 ) zcptn(:,:) = rcp * t n(:,:,1)1137 ! 1138 IF( nn_timing == 1 ) CALL timing_start('sbc_cpl_ice_flx') 1139 ! 1140 CALL wrk_alloc( jpi,jpj, zcptn, ztmp, zicefr ) 1141 1142 zicefr(:,:) = 1.- p_frld(:,:) 1143 IF( lk_diaar5 ) zcptn(:,:) = rcp * tsn(:,:,1,jp_tem) 1118 1144 ! 1119 1145 ! ! ========================= ! … … 1124 1150 ! ! solid precipitation - sublimation (emp_ice) 1125 1151 ! ! solid Precipitation (sprecip) 1126 SELECT CASE( TRIM( cn_rcv_emp) )1152 SELECT CASE( TRIM( sn_rcv_emp%cldes ) ) 1127 1153 CASE( 'conservative' ) ! received fields: jpr_rain, jpr_snow, jpr_ievp, jpr_tevp 1128 pemp_tot(:,:) = frcv(:,:,jpr_tevp) - frcv(:,:,jpr_rain) - frcv(:,:,jpr_snow) 1129 pemp_ice(:,:) = frcv(:,:,jpr_ievp) - frcv(:,:,jpr_snow) 1130 zsnow (:,:) = frcv(:,:,jpr_snow) 1131 CALL iom_put( 'rain' , frcv(:,:,jpr_rain) ) ! liquid precipitation 1132 IF( lk_diaar5 ) CALL iom_put( 'hflx_rain_cea', frcv(:,:,jpr_rain) * zcptn(:,:) ) ! heat flux from liq. precip. 1133 ztmp(:,:) = frcv(:,:,jpr_tevp) - frcv(:,:,jpr_ievp) * zicefr(:,:,1) 1154 sprecip(:,:) = frcv(jpr_snow)%z3(:,:,1) ! May need to ensure positive here 1155 tprecip(:,:) = frcv(jpr_rain)%z3(:,:,1) + sprecip (:,:) ! May need to ensure positive here 1156 emp_tot(:,:) = frcv(jpr_tevp)%z3(:,:,1) - tprecip(:,:) 1157 emp_ice(:,:) = frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_snow)%z3(:,:,1) 1158 CALL iom_put( 'rain' , frcv(jpr_rain)%z3(:,:,1) ) ! liquid precipitation 1159 IF( lk_diaar5 ) CALL iom_put( 'hflx_rain_cea', frcv(jpr_rain)%z3(:,:,1) * zcptn(:,:) ) ! heat flux from liq. precip. 1160 ztmp(:,:) = frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) 1134 1161 CALL iom_put( 'evap_ao_cea' , ztmp ) ! ice-free oce evap (cell average) 1135 1162 IF( lk_diaar5 ) CALL iom_put( 'hflx_evap_cea', ztmp(:,: ) * zcptn(:,:) ) ! heat flux from from evap (cell ave) 1136 CASE( 'oce and ice' ) ! received fields: jpr_sbpr, jpr_semp, jpr_oemp 1137 pemp_tot(:,:) = p_frld(:,:,1) * frcv(:,:,jpr_oemp) + zicefr(:,:,1) * frcv(:,:,jpr_sbpr)1138 pemp_ice(:,:) = frcv(:,:,jpr_semp)1139 zsnow (:,:) = - frcv(:,:,jpr_semp) + frcv(:,:,jpr_ievp)1163 CASE( 'oce and ice' ) ! received fields: jpr_sbpr, jpr_semp, jpr_oemp, jpr_ievp 1164 emp_tot(:,:) = p_frld(:,:) * frcv(jpr_oemp)%z3(:,:,1) + zicefr(:,:) * frcv(jpr_sbpr)%z3(:,:,1) 1165 emp_ice(:,:) = frcv(jpr_semp)%z3(:,:,1) 1166 sprecip(:,:) = - frcv(jpr_semp)%z3(:,:,1) + frcv(jpr_ievp)%z3(:,:,1) 1140 1167 END SELECT 1141 psprecip(:,:) = - pemp_ice(:,:) 1142 CALL iom_put( 'snowpre' , zsnow) ! Snow1143 CALL iom_put( 'snow_ao_cea', zsnow(:,: ) * p_frld(:,:,1)) ! Snow over ice-free ocean (cell average)1144 CALL iom_put( 'snow_ai_cea', zsnow(:,: ) * zicefr(:,:,1)) ! Snow over sea-ice (cell average)1145 CALL iom_put( 'subl_ai_cea', frcv (:,:,jpr_ievp) * zicefr(:,:,1) ) ! Sublimation over sea-ice (cell average)1168 1169 CALL iom_put( 'snowpre' , sprecip ) ! Snow 1170 CALL iom_put( 'snow_ao_cea', sprecip(:,: ) * p_frld(:,:) ) ! Snow over ice-free ocean (cell average) 1171 CALL iom_put( 'snow_ai_cea', sprecip(:,: ) * zicefr(:,:) ) ! Snow over sea-ice (cell average) 1172 CALL iom_put( 'subl_ai_cea', frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) ) ! Sublimation over sea-ice (cell average) 1146 1173 ! 1147 1174 ! ! runoffs and calving (put in emp_tot) 1148 1175 IF( srcv(jpr_rnf)%laction ) THEN 1149 pemp_tot(:,:) = pemp_tot(:,:) - frcv(:,:,jpr_rnf)1150 CALL iom_put( 'runoffs' , frcv( :,:,jpr_rnf) ) ! rivers1151 IF( lk_diaar5 ) CALL iom_put( 'hflx_rnf_cea' , frcv( :,:,jpr_rnf) * zcptn(:,:) ) ! heat flux from rivers1176 emp_tot(:,:) = emp_tot(:,:) - frcv(jpr_rnf)%z3(:,:,1) 1177 CALL iom_put( 'runoffs' , frcv(jpr_rnf)%z3(:,:,1) ) ! rivers 1178 IF( lk_diaar5 ) CALL iom_put( 'hflx_rnf_cea' , frcv(jpr_rnf)%z3(:,:,1) * zcptn(:,:) ) ! heat flux from rivers 1152 1179 ENDIF 1153 1180 IF( srcv(jpr_cal)%laction ) THEN 1154 pemp_tot(:,:) = pemp_tot(:,:) - frcv(:,:,jpr_cal)1155 CALL iom_put( 'calving', frcv( :,:,jpr_cal) )1181 emp_tot(:,:) = emp_tot(:,:) - frcv(jpr_cal)%z3(:,:,1) 1182 CALL iom_put( 'calving', frcv(jpr_cal)%z3(:,:,1) ) 1156 1183 ENDIF 1157 1184 ! … … 1159 1186 !!gm at least should be optional... 1160 1187 !! ! remove negative runoff ! sum over the global domain 1161 !! zcumulpos = SUM( MAX( frcv( :,:,jpr_rnf), 0.e0 ) * e1t(:,:) * e2t(:,:) * tmask_i(:,:) )1162 !! zcumulneg = SUM( MIN( frcv( :,:,jpr_rnf), 0.e0 ) * e1t(:,:) * e2t(:,:) * tmask_i(:,:) )1188 !! zcumulpos = SUM( MAX( frcv(jpr_rnf)%z3(:,:,1), 0.e0 ) * e1t(:,:) * e2t(:,:) * tmask_i(:,:) ) 1189 !! zcumulneg = SUM( MIN( frcv(jpr_rnf)%z3(:,:,1), 0.e0 ) * e1t(:,:) * e2t(:,:) * tmask_i(:,:) ) 1163 1190 !! IF( lk_mpp ) CALL mpp_sum( zcumulpos ) 1164 1191 !! IF( lk_mpp ) CALL mpp_sum( zcumulneg ) 1165 1192 !! IF( zcumulpos /= 0. ) THEN ! distribute negative runoff on positive runoff grid points 1166 1193 !! zcumulneg = 1.e0 + zcumulneg / zcumulpos 1167 !! frcv( :,:,jpr_rnf) = MAX( frcv(:,:,jpr_rnf), 0.e0 ) * zcumulneg1194 !! frcv(jpr_rnf)%z3(:,:,1) = MAX( frcv(jpr_rnf)%z3(:,:,1), 0.e0 ) * zcumulneg 1168 1195 !! ENDIF 1169 !! pemp_tot(:,:) = pemp_tot(:,:) - frcv(:,:,jpr_rnf) ! add runoff to e-p1196 !! emp_tot(:,:) = emp_tot(:,:) - frcv(jpr_rnf)%z3(:,:,1) ! add runoff to e-p 1170 1197 !! 1171 1198 !!gm end of internal cooking 1172 1199 1173 1174 1200 ! ! ========================= ! 1175 SELECT CASE( TRIM( cn_rcv_qns ) )! non solar heat fluxes ! (qns)1201 SELECT CASE( TRIM( sn_rcv_qns%cldes ) ) ! non solar heat fluxes ! (qns) 1176 1202 ! ! ========================= ! 1203 CASE( 'oce only' ) ! the required field is directly provided 1204 qns_tot(:,: ) = frcv(jpr_qnsoce)%z3(:,:,1) 1177 1205 CASE( 'conservative' ) ! the required fields are directly provided 1178 pqns_tot(:,: ) = frcv(:,:,jpr_qnsmix) 1179 pqns_ice(:,:,1) = frcv(:,:,jpr_qnsice) 1206 qns_tot(:,: ) = frcv(jpr_qnsmix)%z3(:,:,1) 1207 IF ( TRIM(sn_rcv_qns%clcat) == 'yes' ) THEN 1208 qns_ice(:,:,1:jpl) = frcv(jpr_qnsice)%z3(:,:,1:jpl) 1209 ELSE 1210 ! Set all category values equal for the moment 1211 DO jl=1,jpl 1212 qns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,1) 1213 ENDDO 1214 ENDIF 1180 1215 CASE( 'oce and ice' ) ! the total flux is computed from ocean and ice fluxes 1181 pqns_tot(:,: ) = p_frld(:,:,1) * frcv(:,:,jpr_qnsoce) + zicefr(:,:,1) * frcv(:,:,jpr_qnsice) 1182 pqns_ice(:,:,1) = frcv(:,:,jpr_qnsice) 1216 qns_tot(:,: ) = p_frld(:,:) * frcv(jpr_qnsoce)%z3(:,:,1) 1217 IF ( TRIM(sn_rcv_qns%clcat) == 'yes' ) THEN 1218 DO jl=1,jpl 1219 qns_tot(:,: ) = qns_tot(:,:) + a_i(:,:,jl) * frcv(jpr_qnsice)%z3(:,:,jl) 1220 qns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,jl) 1221 ENDDO 1222 ELSE 1223 DO jl=1,jpl 1224 qns_tot(:,: ) = qns_tot(:,:) + zicefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1) 1225 qns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,1) 1226 ENDDO 1227 ENDIF 1183 1228 CASE( 'mixed oce-ice' ) ! the ice flux is cumputed from the total flux, the SST and ice informations 1184 pqns_tot(:,: ) = frcv(:,:,jpr_qnsmix) 1185 pqns_ice(:,:,1) = frcv(:,:,jpr_qnsmix) & 1186 & + frcv(:,:,jpr_dqnsdt) * ( pist(:,:,1) - ( (rt0 + psst(:,: ) ) * p_frld(:,:,1) & 1187 & + pist(:,:,1) * zicefr(:,:,1) ) ) 1229 ! ** NEED TO SORT OUT HOW THIS SHOULD WORK IN THE MULTI-CATEGORY CASE - CURRENTLY NOT ALLOWED WHEN INTERFACE INITIALISED ** 1230 qns_tot(:,: ) = frcv(jpr_qnsmix)%z3(:,:,1) 1231 qns_ice(:,:,1) = frcv(jpr_qnsmix)%z3(:,:,1) & 1232 & + frcv(jpr_dqnsdt)%z3(:,:,1) * ( pist(:,:,1) - ( (rt0 + psst(:,: ) ) * p_frld(:,:) & 1233 & + pist(:,:,1) * zicefr(:,:) ) ) 1188 1234 END SELECT 1189 ztmp(:,:) = p_frld(:,: ,1) * zsnow(:,:) * lfus ! add the latent heat of solid precip. melting1190 pqns_tot(:,:) = pqns_tot(:,:) - ztmp(:,:)! over free ocean1191 IF( lk_diaar5 ) CALL iom_put( 'hflx_snow_cea', ztmp + zsnow(:,:) * zcptn(:,:) ) ! heat flux from snow (cell average)1235 ztmp(:,:) = p_frld(:,:) * sprecip(:,:) * lfus ! add the latent heat of solid precip. melting 1236 qns_tot(:,:) = qns_tot(:,:) - ztmp(:,:) ! over free ocean 1237 IF( lk_diaar5 ) CALL iom_put( 'hflx_snow_cea', ztmp + sprecip(:,:) * zcptn(:,:) ) ! heat flux from snow (cell average) 1192 1238 !!gm 1193 1239 !! currently it is taken into account in leads budget but not in the qns_tot, and thus not in … … 1199 1245 ! 1200 1246 IF( srcv(jpr_cal)%laction ) THEN ! Iceberg melting 1201 ztmp(:,:) = frcv( :,:,jpr_cal) * lfus! add the latent heat of iceberg melting1202 pqns_tot(:,:) = pqns_tot(:,:) - ztmp(:,:)1203 IF( lk_diaar5 ) CALL iom_put( 'hflx_cal_cea', ztmp + frcv( :,:,jpr_cal) * zcptn(:,:) ) ! heat flux from calving1247 ztmp(:,:) = frcv(jpr_cal)%z3(:,:,1) * lfus ! add the latent heat of iceberg melting 1248 qns_tot(:,:) = qns_tot(:,:) - ztmp(:,:) 1249 IF( lk_diaar5 ) CALL iom_put( 'hflx_cal_cea', ztmp + frcv(jpr_cal)%z3(:,:,1) * zcptn(:,:) ) ! heat flux from calving 1204 1250 ENDIF 1205 1251 1206 1252 ! ! ========================= ! 1207 SELECT CASE( TRIM( cn_rcv_qsr ) )! solar heat fluxes ! (qsr)1253 SELECT CASE( TRIM( sn_rcv_qsr%cldes ) ) ! solar heat fluxes ! (qsr) 1208 1254 ! ! ========================= ! 1255 CASE( 'oce only' ) 1256 qsr_tot(:,: ) = MAX(0.0,frcv(jpr_qsroce)%z3(:,:,1)) 1209 1257 CASE( 'conservative' ) 1210 pqsr_tot(:,: ) = frcv(:,:,jpr_qsrmix) 1211 pqsr_ice(:,:,1) = frcv(:,:,jpr_qsrice) 1258 qsr_tot(:,: ) = frcv(jpr_qsrmix)%z3(:,:,1) 1259 IF ( TRIM(sn_rcv_qsr%clcat) == 'yes' ) THEN 1260 qsr_ice(:,:,1:jpl) = frcv(jpr_qsrice)%z3(:,:,1:jpl) 1261 ELSE 1262 ! Set all category values equal for the moment 1263 DO jl=1,jpl 1264 qsr_ice(:,:,jl) = frcv(jpr_qsrice)%z3(:,:,1) 1265 ENDDO 1266 ENDIF 1267 qsr_tot(:,: ) = frcv(jpr_qsrmix)%z3(:,:,1) 1268 qsr_ice(:,:,1) = frcv(jpr_qsrice)%z3(:,:,1) 1212 1269 CASE( 'oce and ice' ) 1213 pqsr_tot(:,: ) = p_frld(:,:,1) * frcv(:,:,jpr_qsroce) + zicefr(:,:,1) * frcv(:,:,jpr_qsrice) 1214 pqsr_ice(:,:,1) = frcv(:,:,jpr_qsrice) 1270 qsr_tot(:,: ) = p_frld(:,:) * frcv(jpr_qsroce)%z3(:,:,1) 1271 IF ( TRIM(sn_rcv_qsr%clcat) == 'yes' ) THEN 1272 DO jl=1,jpl 1273 qsr_tot(:,: ) = qsr_tot(:,:) + a_i(:,:,jl) * frcv(jpr_qsrice)%z3(:,:,jl) 1274 qsr_ice(:,:,jl) = frcv(jpr_qsrice)%z3(:,:,jl) 1275 ENDDO 1276 ELSE 1277 DO jl=1,jpl 1278 qsr_tot(:,: ) = qsr_tot(:,:) + zicefr(:,:) * frcv(jpr_qsrice)%z3(:,:,1) 1279 qsr_ice(:,:,jl) = frcv(jpr_qsrice)%z3(:,:,1) 1280 ENDDO 1281 ENDIF 1215 1282 CASE( 'mixed oce-ice' ) 1216 pqsr_tot(:,: ) = frcv(:,:,jpr_qsrmix) 1283 qsr_tot(:,: ) = frcv(jpr_qsrmix)%z3(:,:,1) 1284 ! ** NEED TO SORT OUT HOW THIS SHOULD WORK IN THE MULTI-CATEGORY CASE - CURRENTLY NOT ALLOWED WHEN INTERFACE INITIALISED ** 1217 1285 ! Create solar heat flux over ice using incoming solar heat flux and albedos 1218 1286 ! ( see OASIS3 user guide, 5th edition, p39 ) 1219 pqsr_ice(:,:,1) = frcv(:,:,jpr_qsrmix) * ( 1.- palbi(:,:,1) ) &1220 & / ( 1.- ( albedo_oce_mix(:,: ) * p_frld(:,: ,1)&1221 & + palbi (:,:,1) * zicefr(:,: ,1) ) )1287 qsr_ice(:,:,1) = frcv(jpr_qsrmix)%z3(:,:,1) * ( 1.- palbi(:,:,1) ) & 1288 & / ( 1.- ( albedo_oce_mix(:,: ) * p_frld(:,:) & 1289 & + palbi (:,:,1) * zicefr(:,:) ) ) 1222 1290 END SELECT 1223 1291 IF( ln_dm2dc ) THEN ! modify qsr to include the diurnal cycle 1224 pqsr_tot(:,: ) = sbc_dcy( pqsr_tot(:,: ) ) 1225 pqsr_ice(:,:,1) = sbc_dcy( pqsr_ice(:,:,1) ) 1226 ENDIF 1227 1228 SELECT CASE( TRIM( cn_rcv_dqnsdt ) ) 1292 qsr_tot(:,: ) = sbc_dcy( qsr_tot(:,: ) ) 1293 DO jl=1,jpl 1294 qsr_ice(:,:,jl) = sbc_dcy( qsr_ice(:,:,jl) ) 1295 ENDDO 1296 ENDIF 1297 1298 SELECT CASE( TRIM( sn_rcv_dqnsdt%cldes ) ) 1229 1299 CASE ('coupled') 1230 pdqns_ice(:,:,1) = frcv(:,:,jpr_dqnsdt) 1300 IF ( TRIM(sn_rcv_dqnsdt%clcat) == 'yes' ) THEN 1301 dqns_ice(:,:,1:jpl) = frcv(jpr_dqnsdt)%z3(:,:,1:jpl) 1302 ELSE 1303 ! Set all category values equal for the moment 1304 DO jl=1,jpl 1305 dqns_ice(:,:,jl) = frcv(jpr_dqnsdt)%z3(:,:,1) 1306 ENDDO 1307 ENDIF 1231 1308 END SELECT 1232 1309 1233 IF( wrk_not_released(2, 1,2,3) .OR. & 1234 wrk_not_released(3, 4) ) CALL ctl_stop('sbc_cpl_ice_flx: failed to release workspace arrays') 1310 SELECT CASE( TRIM( sn_rcv_iceflx%cldes ) ) 1311 CASE ('coupled') 1312 topmelt(:,:,:)=frcv(jpr_topm)%z3(:,:,:) 1313 botmelt(:,:,:)=frcv(jpr_botm)%z3(:,:,:) 1314 END SELECT 1315 1316 CALL wrk_dealloc( jpi,jpj, zcptn, ztmp, zicefr ) 1317 ! 1318 IF( nn_timing == 1 ) CALL timing_stop('sbc_cpl_ice_flx') 1235 1319 ! 1236 1320 END SUBROUTINE sbc_cpl_ice_flx … … 1246 1330 !! all the needed fields (as defined in sbc_cpl_init) 1247 1331 !!---------------------------------------------------------------------- 1248 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released1249 USE wrk_nemo, ONLY: zfr_l => wrk_2d_1 ! 1. - fr_i(:,:)1250 USE wrk_nemo, ONLY: ztmp1 => wrk_2d_2 , ztmp2 => wrk_2d_31251 USE wrk_nemo, ONLY: zotx1 => wrk_2d_4 , zoty1 => wrk_2d_5 , zotz1 => wrk_2d_61252 USE wrk_nemo, ONLY: zitx1 => wrk_2d_7 , zity1 => wrk_2d_8 , zitz1 => wrk_2d_91253 !1254 1332 INTEGER, INTENT(in) :: kt 1255 1333 ! 1256 INTEGER :: ji, jj 1334 INTEGER :: ji, jj, jl ! dummy loop indices 1257 1335 INTEGER :: isec, info ! local integer 1336 REAL(wp), POINTER, DIMENSION(:,:) :: zfr_l, ztmp1, ztmp2, zotx1, zoty1, zotz1, zitx1, zity1, zitz1 1337 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztmp3, ztmp4 1258 1338 !!---------------------------------------------------------------------- 1259 1260 IF( wrk_in_use(2, 1,2,3,4,5,6,7,8,9) ) THEN 1261 CALL ctl_stop('sbc_cpl_snd: requested workspace arrays are unavailable') ; RETURN 1262 ENDIF 1339 ! 1340 IF( nn_timing == 1 ) CALL timing_start('sbc_cpl_snd') 1341 ! 1342 CALL wrk_alloc( jpi,jpj, zfr_l, ztmp1, ztmp2, zotx1, zoty1, zotz1, zitx1, zity1, zitz1 ) 1343 CALL wrk_alloc( jpi,jpj,jpl, ztmp3, ztmp4 ) 1263 1344 1264 1345 isec = ( kt - nit000 ) * NINT(rdttra(1)) ! date of exchanges … … 1269 1350 ! ! Surface temperature ! in Kelvin 1270 1351 ! ! ------------------------- ! 1271 SELECT CASE( cn_snd_temperature) 1272 CASE( 'oce only' ) ; ztmp1(:,:) = tn(:,:,1) + rt0 1273 CASE( 'weighted oce and ice' ) ; ztmp1(:,:) = ( tn(:,:,1) + rt0 ) * zfr_l(:,:) 1274 ztmp2(:,:) = tn_ice(:,:,1) * fr_i(:,:) 1275 CASE( 'mixed oce-ice' ) ; ztmp1(:,:) = ( tn(:,:,1) + rt0 ) * zfr_l(:,:) + tn_ice(:,:,1) * fr_i(:,:) 1276 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of cn_snd_temperature' ) 1352 SELECT CASE( sn_snd_temp%cldes) 1353 CASE( 'oce only' ) ; ztmp1(:,:) = tsn(:,:,1,jp_tem) + rt0 1354 CASE( 'weighted oce and ice' ) ; ztmp1(:,:) = ( tsn(:,:,1,jp_tem) + rt0 ) * zfr_l(:,:) 1355 SELECT CASE( sn_snd_temp%clcat ) 1356 CASE( 'yes' ) 1357 ztmp3(:,:,1:jpl) = tn_ice(:,:,1:jpl) * a_i(:,:,1:jpl) 1358 CASE( 'no' ) 1359 ztmp3(:,:,:) = 0.0 1360 DO jl=1,jpl 1361 ztmp3(:,:,1) = ztmp3(:,:,1) + tn_ice(:,:,jl) * a_i(:,:,jl) 1362 ENDDO 1363 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%clcat' ) 1364 END SELECT 1365 CASE( 'mixed oce-ice' ) 1366 ztmp1(:,:) = ( tsn(:,:,1,1) + rt0 ) * zfr_l(:,:) 1367 DO jl=1,jpl 1368 ztmp1(:,:) = ztmp1(:,:) + tn_ice(:,:,jl) * a_i(:,:,jl) 1369 ENDDO 1370 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%cldes' ) 1277 1371 END SELECT 1278 IF( ssnd(jps_toce)%laction ) CALL cpl_prism_snd( jps_toce, isec, ztmp1, info )1279 IF( ssnd(jps_tice)%laction ) CALL cpl_prism_snd( jps_tice, isec, ztmp 2, info )1280 IF( ssnd(jps_tmix)%laction ) CALL cpl_prism_snd( jps_tmix, isec, ztmp1, info )1372 IF( ssnd(jps_toce)%laction ) CALL cpl_prism_snd( jps_toce, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info ) 1373 IF( ssnd(jps_tice)%laction ) CALL cpl_prism_snd( jps_tice, isec, ztmp3, info ) 1374 IF( ssnd(jps_tmix)%laction ) CALL cpl_prism_snd( jps_tmix, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info ) 1281 1375 ! 1282 1376 ! ! ------------------------- ! … … 1284 1378 ! ! ------------------------- ! 1285 1379 IF( ssnd(jps_albice)%laction ) THEN ! ice 1286 ztmp 1(:,:) = alb_ice(:,:,1) * fr_i(:,:)1287 CALL cpl_prism_snd( jps_albice, isec, ztmp 1, info )1380 ztmp3(:,:,1:jpl) = alb_ice(:,:,1:jpl) * a_i(:,:,1:jpl) 1381 CALL cpl_prism_snd( jps_albice, isec, ztmp3, info ) 1288 1382 ENDIF 1289 1383 IF( ssnd(jps_albmix)%laction ) THEN ! mixed ice-ocean 1290 ztmp1(:,:) = albedo_oce_mix(:,:) * zfr_l(:,:) + alb_ice(:,:,1) * fr_i(:,:) 1291 CALL cpl_prism_snd( jps_albmix, isec, ztmp1, info ) 1384 ztmp1(:,:) = albedo_oce_mix(:,:) * zfr_l(:,:) 1385 DO jl=1,jpl 1386 ztmp1(:,:) = ztmp1(:,:) + alb_ice(:,:,jl) * a_i(:,:,jl) 1387 ENDDO 1388 CALL cpl_prism_snd( jps_albmix, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info ) 1292 1389 ENDIF 1293 1390 ! ! ------------------------- ! 1294 1391 ! ! Ice fraction & Thickness ! 1295 1392 ! ! ------------------------- ! 1296 IF( ssnd(jps_fice)%laction ) CALL cpl_prism_snd( jps_fice, isec, fr_i , info ) 1297 IF( ssnd(jps_hice)%laction ) CALL cpl_prism_snd( jps_hice, isec, hicif(:,:) * fr_i(:,:), info ) 1298 IF( ssnd(jps_hsnw)%laction ) CALL cpl_prism_snd( jps_hsnw, isec, hsnif(:,:) * fr_i(:,:), info ) 1393 ! Send ice fraction field 1394 SELECT CASE( sn_snd_thick%clcat ) 1395 CASE( 'yes' ) 1396 ztmp3(:,:,1:jpl) = a_i(:,:,1:jpl) 1397 CASE( 'no' ) 1398 ztmp3(:,:,1) = fr_i(:,:) 1399 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%clcat' ) 1400 END SELECT 1401 IF( ssnd(jps_fice)%laction ) CALL cpl_prism_snd( jps_fice, isec, ztmp3, info ) 1402 1403 ! Send ice and snow thickness field 1404 SELECT CASE( sn_snd_thick%cldes) 1405 CASE( 'weighted ice and snow' ) 1406 SELECT CASE( sn_snd_thick%clcat ) 1407 CASE( 'yes' ) 1408 ztmp3(:,:,1:jpl) = ht_i(:,:,1:jpl) * a_i(:,:,1:jpl) 1409 ztmp4(:,:,1:jpl) = ht_s(:,:,1:jpl) * a_i(:,:,1:jpl) 1410 CASE( 'no' ) 1411 ztmp3(:,:,:) = 0.0 ; ztmp4(:,:,:) = 0.0 1412 DO jl=1,jpl 1413 ztmp3(:,:,1) = ztmp3(:,:,1) + ht_i(:,:,jl) * a_i(:,:,jl) 1414 ztmp4(:,:,1) = ztmp4(:,:,1) + ht_s(:,:,jl) * a_i(:,:,jl) 1415 ENDDO 1416 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%clcat' ) 1417 END SELECT 1418 CASE( 'ice and snow' ) 1419 ztmp3(:,:,1:jpl) = ht_i(:,:,1:jpl) 1420 ztmp4(:,:,1:jpl) = ht_s(:,:,1:jpl) 1421 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%cldes' ) 1422 END SELECT 1423 IF( ssnd(jps_hice)%laction ) CALL cpl_prism_snd( jps_hice, isec, ztmp3, info ) 1424 IF( ssnd(jps_hsnw)%laction ) CALL cpl_prism_snd( jps_hsnw, isec, ztmp4, info ) 1299 1425 ! 1300 1426 #if defined key_cpl_carbon_cycle … … 1302 1428 ! ! CO2 flux from PISCES ! 1303 1429 ! ! ------------------------- ! 1304 IF( ssnd(jps_co2)%laction ) CALL cpl_prism_snd( jps_co2, isec, oce_co2, info )1430 IF( ssnd(jps_co2)%laction ) CALL cpl_prism_snd( jps_co2, isec, RESHAPE ( oce_co2, (/jpi,jpj,1/) ) , info ) 1305 1431 ! 1306 1432 #endif 1433 ! ! ------------------------- ! 1307 1434 IF( ssnd(jps_ocx1)%laction ) THEN ! Surface current ! 1308 1435 ! ! ------------------------- ! … … 1316 1443 ! i-1 i i 1317 1444 ! i i+1 (for I) 1318 SELECT CASE( TRIM( cn_snd_crt(1)) )1445 SELECT CASE( TRIM( sn_snd_crt%cldes ) ) 1319 1446 CASE( 'oce only' ) ! C-grid ==> T 1320 1447 DO jj = 2, jpjm1 … … 1394 1521 END SELECT 1395 1522 END SELECT 1396 CALL lbc_lnk( zotx1, 'T', -1. ) ; CALL lbc_lnk( zoty1, 'T', -1. )1523 CALL lbc_lnk( zotx1, ssnd(jps_ocx1)%clgrid, -1. ) ; CALL lbc_lnk( zoty1, ssnd(jps_ocy1)%clgrid, -1. ) 1397 1524 ! 1398 1525 ! 1399 IF( TRIM( cn_snd_crt(3)) == 'eastward-northward' ) THEN ! Rotation of the components1526 IF( TRIM( sn_snd_crt%clvor ) == 'eastward-northward' ) THEN ! Rotation of the components 1400 1527 ! ! Ocean component 1401 1528 CALL rot_rep( zotx1, zoty1, ssnd(jps_ocx1)%clgrid, 'ij->e', ztmp1 ) ! 1st component … … 1412 1539 ! 1413 1540 ! spherical coordinates to cartesian -> 2 components to 3 components 1414 IF( TRIM( cn_snd_crt(2)) == 'cartesian' ) THEN1541 IF( TRIM( sn_snd_crt%clvref ) == 'cartesian' ) THEN 1415 1542 ztmp1(:,:) = zotx1(:,:) ! ocean currents 1416 1543 ztmp2(:,:) = zoty1(:,:) … … 1424 1551 ENDIF 1425 1552 ! 1426 IF( ssnd(jps_ocx1)%laction ) CALL cpl_prism_snd( jps_ocx1, isec, zotx1, info ) ! ocean x current 1st grid1427 IF( ssnd(jps_ocy1)%laction ) CALL cpl_prism_snd( jps_ocy1, isec, zoty1, info ) ! ocean y current 1st grid1428 IF( ssnd(jps_ocz1)%laction ) CALL cpl_prism_snd( jps_ocz1, isec, zotz1, info ) ! ocean z current 1st grid1553 IF( ssnd(jps_ocx1)%laction ) CALL cpl_prism_snd( jps_ocx1, isec, RESHAPE ( zotx1, (/jpi,jpj,1/) ), info ) ! ocean x current 1st grid 1554 IF( ssnd(jps_ocy1)%laction ) CALL cpl_prism_snd( jps_ocy1, isec, RESHAPE ( zoty1, (/jpi,jpj,1/) ), info ) ! ocean y current 1st grid 1555 IF( ssnd(jps_ocz1)%laction ) CALL cpl_prism_snd( jps_ocz1, isec, RESHAPE ( zotz1, (/jpi,jpj,1/) ), info ) ! ocean z current 1st grid 1429 1556 ! 1430 IF( ssnd(jps_ivx1)%laction ) CALL cpl_prism_snd( jps_ivx1, isec, zitx1, info ) ! ice x current 1st grid1431 IF( ssnd(jps_ivy1)%laction ) CALL cpl_prism_snd( jps_ivy1, isec, zity1, info ) ! ice y current 1st grid1432 IF( ssnd(jps_ivz1)%laction ) CALL cpl_prism_snd( jps_ivz1, isec, zitz1, info ) ! ice z current 1st grid1557 IF( ssnd(jps_ivx1)%laction ) CALL cpl_prism_snd( jps_ivx1, isec, RESHAPE ( zitx1, (/jpi,jpj,1/) ), info ) ! ice x current 1st grid 1558 IF( ssnd(jps_ivy1)%laction ) CALL cpl_prism_snd( jps_ivy1, isec, RESHAPE ( zity1, (/jpi,jpj,1/) ), info ) ! ice y current 1st grid 1559 IF( ssnd(jps_ivz1)%laction ) CALL cpl_prism_snd( jps_ivz1, isec, RESHAPE ( zitz1, (/jpi,jpj,1/) ), info ) ! ice z current 1st grid 1433 1560 ! 1434 1561 ENDIF 1435 1562 ! 1436 IF( wrk_not_released(2, 1,2,3,4,5,6,7,8,9) ) CALL ctl_stop('sbc_cpl_snd: failed to release workspace arrays') 1563 CALL wrk_dealloc( jpi,jpj, zfr_l, ztmp1, ztmp2, zotx1, zoty1, zotz1, zitx1, zity1, zitz1 ) 1564 CALL wrk_dealloc( jpi,jpj,jpl, ztmp3, ztmp4 ) 1565 ! 1566 IF( nn_timing == 1 ) CALL timing_stop('sbc_cpl_snd') 1437 1567 ! 1438 1568 END SUBROUTINE sbc_cpl_snd … … 1459 1589 END SUBROUTINE sbc_cpl_ice_tau 1460 1590 ! 1461 SUBROUTINE sbc_cpl_ice_flx( p_frld , & 1462 & pqns_tot, pqns_ice, pqsr_tot , pqsr_ice, & 1463 & pemp_tot, pemp_ice, pdqns_ice, psprecip, & 1464 & palbi , psst , pist ) 1465 REAL(wp), INTENT(in ), DIMENSION(:,:,:) :: p_frld ! lead fraction [0 to 1] 1466 REAL(wp), INTENT( out), DIMENSION(:,: ) :: pqns_tot ! total non solar heat flux [W/m2] 1467 REAL(wp), INTENT( out), DIMENSION(:,:,:) :: pqns_ice ! ice non solar heat flux [W/m2] 1468 REAL(wp), INTENT( out), DIMENSION(:,: ) :: pqsr_tot ! total solar heat flux [W/m2] 1469 REAL(wp), INTENT( out), DIMENSION(:,:,:) :: pqsr_ice ! ice solar heat flux [W/m2] 1470 REAL(wp), INTENT( out), DIMENSION(:,: ) :: pemp_tot ! total freshwater budget [Kg/m2/s] 1471 REAL(wp), INTENT( out), DIMENSION(:,: ) :: pemp_ice ! ice solid freshwater budget [Kg/m2/s] 1472 REAL(wp), INTENT( out), DIMENSION(:,:,:) :: pdqns_ice ! d(Q non solar)/d(Temperature) over ice 1473 REAL(wp), INTENT( out), DIMENSION(:,: ) :: psprecip ! solid precipitation [Kg/m2/s] 1591 SUBROUTINE sbc_cpl_ice_flx( p_frld , palbi , psst , pist ) 1592 REAL(wp), INTENT(in ), DIMENSION(:,: ) :: p_frld ! lead fraction [0 to 1] 1474 1593 REAL(wp), INTENT(in ), DIMENSION(:,:,:), OPTIONAL :: palbi ! ice albedo 1475 1594 REAL(wp), INTENT(in ), DIMENSION(:,: ), OPTIONAL :: psst ! sea surface temperature [Celcius] 1476 1595 REAL(wp), INTENT(in ), DIMENSION(:,:,:), OPTIONAL :: pist ! ice surface temperature [Kelvin] 1477 WRITE(*,*) 'sbc_cpl_snd: You should not have seen this print! error?', p_frld(1,1,1), palbi(1,1,1), psst(1,1), pist(1,1,1) 1478 ! stupid definition to avoid warning message when compiling... 1479 pqns_tot(:,:) = 0. ; pqns_ice(:,:,:) = 0. ; pdqns_ice(:,:,:) = 0. 1480 pqsr_tot(:,:) = 0. ; pqsr_ice(:,:,:) = 0. 1481 pemp_tot(:,:) = 0. ; pemp_ice(:,:) = 0. ; psprecip(:,:) = 0. 1596 WRITE(*,*) 'sbc_cpl_snd: You should not have seen this print! error?', p_frld(1,1), palbi(1,1,1), psst(1,1), pist(1,1,1) 1482 1597 END SUBROUTINE sbc_cpl_ice_flx 1483 1598 -
trunk/NEMOGCM/NEMO/OPA_SRC/SBC/sbcdcy.F90
r2715 r3294 18 18 USE in_out_manager ! I/O manager 19 19 USE lib_mpp ! MPP library 20 USE timing ! Timing 20 21 21 22 IMPLICIT NONE … … 76 77 & - paaa * pt1 - zinvtwopi * pbbb * SIN(pccc + ztwopi * pt1) 77 78 !!--------------------------------------------------------------------- 78 79 ! 80 IF( nn_timing == 1 ) CALL timing_start('sbc_dcy') 81 ! 79 82 ! Initialization 80 83 ! -------------- … … 221 224 END DO 222 225 ! 226 IF( nn_timing == 1 ) CALL timing_stop('sbc_dcy') 227 ! 223 228 END FUNCTION sbc_dcy 224 229 -
trunk/NEMOGCM/NEMO/OPA_SRC/SBC/sbcfwb.F90
r2715 r3294 22 22 USE in_out_manager ! I/O manager 23 23 USE lib_mpp ! distribued memory computing library 24 USE wrk_nemo ! work arrays 25 USE timing ! Timing 24 26 USE lbclnk ! ocean lateral boundary conditions 25 27 USE lib_fortran … … 58 60 !! & spread out over erp area depending its sign 59 61 !!---------------------------------------------------------------------- 60 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released61 USE wrk_nemo, ONLY: ztmsk_neg => wrk_2d_1 , ztmsk_pos => wrk_2d_262 USE wrk_nemo, ONLY: ztmsk_tospread => wrk_2d_363 USE wrk_nemo, ONLY: z_wgt => wrk_2d_4 , zerp_cor => wrk_2d_564 !65 62 INTEGER, INTENT( in ) :: kt ! ocean time-step index 66 63 INTEGER, INTENT( in ) :: kn_fsbc ! … … 70 67 REAL(wp) :: z_fwf, z_fwf_nsrf, zsum_fwf, zsum_erp ! local scalars 71 68 REAL(wp) :: zsurf_neg, zsurf_pos, zsurf_tospread ! - - 69 REAL(wp), POINTER, DIMENSION(:,:) :: ztmsk_neg, ztmsk_pos, ztmsk_tospread, z_wgt, zerp_cor 72 70 !!---------------------------------------------------------------------- 73 71 ! 74 IF( wrk_in_use(2, 1,2,3,4,5) ) THEN75 CALL ctl_stop('sbc_fwb: requested workspace arrays are unavailable') ; RETURN76 ENDIF72 IF( nn_timing == 1 ) CALL timing_start('sbc_fwb') 73 ! 74 CALL wrk_alloc( jpi,jpj, ztmsk_neg, ztmsk_pos, ztmsk_tospread, z_wgt, zerp_cor ) 77 75 ! 78 76 IF( kt == nit000 ) THEN … … 195 193 END SELECT 196 194 ! 197 IF( wrk_not_released(2, 1,2,3,4,5) ) CALL ctl_stop('sbc_fwb: failed to release workspace arrays') 195 CALL wrk_dealloc( jpi,jpj, ztmsk_neg, ztmsk_pos, ztmsk_tospread, z_wgt, zerp_cor ) 196 ! 197 IF( nn_timing == 1 ) CALL timing_stop('sbc_fwb') 198 198 ! 199 199 END SUBROUTINE sbc_fwb -
trunk/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_if.F90
r2715 r3294 16 16 USE eosbn2 ! equation of state 17 17 USE sbc_oce ! surface boundary condition: ocean fields 18 USE sbccpl 18 19 USE fldread ! read input field 19 20 USE iom ! I/O manager library … … 97 98 98 99 fr_i(:,:) = tfreez( sss_m ) * tmask(:,:,1) ! sea surface freezing temperature [Celcius] 100 #if defined key_coupled 101 a_i(:,:,1) = fr_i(:,:) 102 #endif 99 103 100 104 ! Flux and ice fraction computation … … 110 114 ENDIF 111 115 112 t n(ji,jj,1) = MAX( tn(ji,jj,1), zt_fzp ) ! avoid over-freezing point temperature116 tsn(ji,jj,1,jp_tem) = MAX( tsn(ji,jj,1,jp_tem), zt_fzp ) ! avoid over-freezing point temperature 113 117 114 118 qsr(ji,jj) = ( 1. - zfr_obs ) * qsr(ji,jj) ! solar heat flux : zero below observed ice cover … … 117 121 ! # ztrp*(t-(tgel-1.)) if observed ice and no opa ice (zfr_obs=1 fr_i=0) 118 122 ! # ztrp*min(0,t-tgel) if observed ice and opa ice (zfr_obs=1 fr_i=1) 119 zqri = ztrp * ( t b(ji,jj,1) - ( zt_fzp - 1.) )120 zqrj = ztrp * MIN( 0., t b(ji,jj,1) - zt_fzp )123 zqri = ztrp * ( tsb(ji,jj,1,jp_tem) - ( zt_fzp - 1.) ) 124 zqrj = ztrp * MIN( 0., tsb(ji,jj,1,jp_tem) - zt_fzp ) 121 125 zqrp = ( zfr_obs * ( (1. - fr_i(ji,jj) ) * zqri & 122 126 & + fr_i(ji,jj) * zqrj ) ) * tmask(ji,jj,1) -
trunk/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_lim.F90
r2777 r3294 50 50 USE lbclnk ! lateral boundary condition - MPP link 51 51 USE lib_mpp ! MPP library 52 USE wrk_nemo ! work arrays 52 53 USE iom ! I/O manager library 53 54 USE in_out_manager ! I/O manager … … 89 90 !! utau, vtau, taum, wndm, qns , qsr, emp , emps 90 91 !!--------------------------------------------------------------------- 91 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released92 USE wrk_nemo, ONLY: wrk_3d_1, wrk_3d_2 ! for albedo of ice under overcast/clear sky93 !!94 92 INTEGER, INTENT(in) :: kt ! ocean time step 95 93 INTEGER, INTENT(in) :: kblk ! type of bulk (=3 CLIO, =4 CORE) … … 100 98 !!---------------------------------------------------------------------- 101 99 102 IF( wrk_in_use(3, 1,2) ) THEN 103 CALL ctl_stop( 'sbc_ice_lim: requested workspace arrays are unavailable' ) ; RETURN 104 ENDIF 105 zalb_ice_os => wrk_3d_1(:,:,1:jpl) ; zalb_ice_cs => wrk_3d_2(:,:,1:jpl) 100 CALL wrk_alloc( jpi,jpj,jpl, zalb_ice_os, zalb_ice_cs ) 106 101 107 102 IF( kt == nit000 ) THEN … … 253 248 !!gm remark, the ocean-ice stress is not saved in ice diag call above ..... find a solution!!! 254 249 ! 255 IF( wrk_not_released(3, 1,2) ) CALL ctl_stop( 'sbc_ice_lim: failed to release workspace arrays')250 CALL wrk_dealloc( jpi,jpj,jpl, zalb_ice_os, zalb_ice_cs ) 256 251 ! 257 252 END SUBROUTINE sbc_ice_lim -
trunk/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_lim_2.F90
r2715 r3294 44 44 USE lbclnk ! lateral boundary condition - MPP link 45 45 USE lib_mpp ! MPP library 46 USE wrk_nemo ! work arrays 46 47 USE iom ! I/O manager library 47 48 USE in_out_manager ! I/O manager … … 83 84 !! utau, vtau, taum, wndm, qns , qsr, emp , emps 84 85 !!--------------------------------------------------------------------- 85 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released86 USE wrk_nemo, ONLY: wrk_3d_1 , wrk_3d_2 , wrk_3d_3 ! 3D workspace87 !!88 86 INTEGER, INTENT(in) :: kt ! ocean time step 89 87 INTEGER, INTENT(in) :: ksbc ! type of sbc ( =3 CLIO bulk ; =4 CORE bulk ; =5 coupled ) 90 88 !! 91 89 INTEGER :: ji, jj ! dummy loop indices 92 ! Pointers into workspaces contained in the wrk_nemo module93 90 REAL(wp), DIMENSION(:,:,:), POINTER :: zalb_ice_os ! albedo of the ice under overcast sky 94 91 REAL(wp), DIMENSION(:,:,:), POINTER :: zalb_ice_cs ! albedo of ice under clear sky … … 96 93 !!---------------------------------------------------------------------- 97 94 98 IF( wrk_in_use(3, 1,2,3) ) THEN 99 CALL ctl_stop('sbc_ice_lim_2: requested workspace arrays are unavailable') ; RETURN 100 ENDIF 101 ! Use pointers to access only sub-arrays of workspaces 102 zalb_ice_os => wrk_3d_1(:,:,1:1) 103 zalb_ice_cs => wrk_3d_2(:,:,1:1) 104 zsist => wrk_3d_3(:,:,1:1) 95 CALL wrk_alloc( jpi,jpj,1, zalb_ice_os, zalb_ice_cs, zsist ) 105 96 106 97 IF( kt == nit000 ) THEN … … 202 193 #if defined key_coupled 203 194 ! ! Ice surface fluxes in coupled mode 204 IF( ksbc == 5 ) CALL sbc_cpl_ice_flx( reshape( frld, (/jpi,jpj,1/) ), &205 & qns_tot, qns_ice, qsr_tot , qsr_ice, &206 & emp_tot, emp_ice, dqns_ice, sprecip,&195 IF( ksbc == 5 ) THEN 196 a_i(:,:,1)=fr_i 197 CALL sbc_cpl_ice_flx( frld, & 207 198 ! optional arguments, used only in 'mixed oce-ice' case 208 199 & palbi = zalb_ice_cs, psst = sst_m, pist = zsist ) 200 sprecip(:,:) = - emp_ice(:,:) ! Ugly patch, WARNING, in coupled mode, sublimation included in snow (parsub = 0.) 201 ENDIF 209 202 #endif 210 203 CALL lim_thd_2 ( kt ) ! Ice thermodynamics … … 228 221 IF( ln_limdyn ) CALL lim_sbc_tau_2( kt, ub(:,:,1), vb(:,:,1) ) ! using before instantaneous surf. currents 229 222 ! 230 IF( wrk_not_released(3, 1,2,3) ) CALL ctl_stop('sbc_ice_lim_2: failed to release workspace arrays')223 CALL wrk_dealloc( jpi,jpj,1, zalb_ice_os, zalb_ice_cs, zsist ) 231 224 ! 232 225 END SUBROUTINE sbc_ice_lim_2 -
trunk/NEMOGCM/NEMO/OPA_SRC/SBC/sbcmod.F90
r2715 r3294 11 11 !! - ! 2010-11 (G. Madec) ice-ocean stress always computed at each ocean time-step 12 12 !! - ! 2010-10 (J. Chanut, C. Bricaud, G. Madec) add the surface pressure forcing 13 !! 3.4 ! 2011-11 (C. Harris) CICE added as an option 13 14 !!---------------------------------------------------------------------- 14 15 … … 29 30 USE sbcblk_clio ! surface boundary condition: bulk formulation : CLIO 30 31 USE sbcblk_core ! surface boundary condition: bulk formulation : CORE 32 USE sbcblk_mfs ! surface boundary condition: bulk formulation : MFS 31 33 USE sbcice_if ! surface boundary condition: ice-if sea-ice model 32 34 USE sbcice_lim ! surface boundary condition: LIM 3.0 sea-ice model 33 35 USE sbcice_lim_2 ! surface boundary condition: LIM 2.0 sea-ice model 36 USE sbcice_cice ! surface boundary condition: CICE sea-ice model 34 37 USE sbccpl ! surface boundary condition: coupled florulation 35 38 USE cpl_oasis3, ONLY:lk_cpl ! are we in coupled mode? … … 38 41 USE sbcfwb ! surface boundary condition: freshwater budget 39 42 USE closea ! closed sea 40 USE bdy_par ! unstructured open boundary data variables41 USE bdyice ! unstructured open boundary data (bdy_ice_frsroutine)43 USE bdy_par ! for lk_bdy 44 USE bdyice_lim2 ! unstructured open boundary data (bdy_ice_lim_2 routine) 42 45 43 46 USE prtctl ! Print control (prt_ctl routine) … … 46 49 USE in_out_manager ! I/O manager 47 50 USE lib_mpp ! MPP library 51 USE timing ! Timing 52 USE sbcwave ! Wave module 48 53 49 54 IMPLICIT NONE … … 78 83 !! 79 84 NAMELIST/namsbc/ nn_fsbc , ln_ana , ln_flx , ln_blk_clio, ln_blk_core, ln_cpl, & 80 & ln_ apr_dyn, nn_ice , ln_dm2dc, ln_rnf , ln_ssr , nn_fwb85 & ln_blk_mfs, ln_apr_dyn, nn_ice , ln_dm2dc, ln_rnf, ln_ssr , nn_fwb, ln_cdgw 81 86 !!---------------------------------------------------------------------- 82 87 … … 94 99 IF( lk_lim2 ) nn_ice = 2 95 100 IF( lk_lim3 ) nn_ice = 3 101 IF( lk_cice ) nn_ice = 4 96 102 ENDIF 97 103 IF( cp_cfg == 'gyre' ) THEN ! GYRE configuration … … 107 113 WRITE(numout,*) ' flux formulation ln_flx = ', ln_flx 108 114 WRITE(numout,*) ' CLIO bulk formulation ln_blk_clio = ', ln_blk_clio 109 WRITE(numout,*) ' CLIO bulk formulation ln_blk_core = ', ln_blk_core 115 WRITE(numout,*) ' CORE bulk formulation ln_blk_core = ', ln_blk_core 116 WRITE(numout,*) ' MFS bulk formulation ln_blk_mfs = ', ln_blk_mfs 110 117 WRITE(numout,*) ' coupled formulation (T if key_sbc_cpl) ln_cpl = ', ln_cpl 111 118 WRITE(numout,*) ' Misc. options of sbc : ' … … 144 151 & CALL ctl_warn( 'nn_fsbc is NOT a multiple of the number of time steps in a day' ) 145 152 ! 146 IF( nn_ice == 2 .AND. .NOT.( ln_blk_clio .OR. ln_blk_core .OR. lk_cpl ) ) & 147 & CALL ctl_stop( 'sea-ice model requires a bulk formulation or coupled configuration' ) 153 IF( ( nn_ice == 2 .OR. nn_ice ==3 ) .AND. .NOT.( ln_blk_clio .OR. ln_blk_core .OR. lk_cpl ) ) & 154 & CALL ctl_stop( 'LIM sea-ice model requires a bulk formulation or coupled configuration' ) 155 IF( nn_ice == 4 .AND. .NOT.( ln_blk_core .OR. lk_cpl ) ) & 156 & CALL ctl_stop( 'CICE sea-ice model requires ln_blk_core or lk_cpl' ) 157 IF( nn_ice == 4 .AND. ( .NOT. ( cp_cfg == 'orca' ) .OR. lk_agrif ) ) & 158 & CALL ctl_stop( 'CICE sea-ice model currently only available in a global ORCA configuration without AGRIF' ) 148 159 149 160 IF( ln_dm2dc ) nday_qsr = -1 ! initialisation flag … … 154 165 IF( ln_dm2dc .AND. ( ( NINT(rday) / ( nn_fsbc * NINT(rdt) ) ) < 8 ) ) & 155 166 & CALL ctl_warn( 'diurnal cycle for qsr: the sampling of the diurnal cycle is too small...' ) 167 168 !drag coefficient read from wave model definable only with mfs bulk formulae and core 169 IF(ln_cdgw .AND. .NOT.(ln_blk_mfs .OR. ln_blk_core) ) & 170 & CALL ctl_stop( 'drag coefficient read from wave model definable only with mfs bulk formulae and core') 156 171 157 172 ! ! Choice of the Surface Boudary Condition (set nsbc) … … 161 176 IF( ln_blk_clio ) THEN ; nsbc = 3 ; icpt = icpt + 1 ; ENDIF ! CLIO bulk formulation 162 177 IF( ln_blk_core ) THEN ; nsbc = 4 ; icpt = icpt + 1 ; ENDIF ! CORE bulk formulation 178 IF( ln_blk_mfs ) THEN ; nsbc = 6 ; icpt = icpt + 1 ; ENDIF ! MFS bulk formulation 163 179 IF( ln_cpl ) THEN ; nsbc = 5 ; icpt = icpt + 1 ; ENDIF ! Coupled formulation 164 180 IF( cp_cfg == 'gyre') THEN ; nsbc = 0 ; ENDIF ! GYRE analytical formulation … … 181 197 IF( nsbc == 4 ) WRITE(numout,*) ' CORE bulk formulation' 182 198 IF( nsbc == 5 ) WRITE(numout,*) ' coupled formulation' 183 ENDIF 199 IF( nsbc == 6 ) WRITE(numout,*) ' MFS Bulk formulation' 200 ENDIF 201 202 IF( nn_ice == 4 ) CALL cice_sbc_init (nsbc) 184 203 ! 185 204 END SUBROUTINE sbc_init … … 204 223 INTEGER, INTENT(in) :: kt ! ocean time step 205 224 !!--------------------------------------------------------------------- 206 225 ! 226 IF( nn_timing == 1 ) CALL timing_start('sbc') 227 ! 207 228 ! ! ---------------------------------------- ! 208 229 IF( kt /= nit000 ) THEN ! Swap of forcing fields ! … … 228 249 ! ! averaged over nf_sbc time-step 229 250 251 IF (ln_cdgw) CALL sbc_wave( kt ) 230 252 !== sbc formulation ==! 231 253 … … 238 260 CASE( 4 ) ; CALL sbc_blk_core( kt ) ! bulk formulation : CORE for the ocean 239 261 CASE( 5 ) ; CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice ) ! coupled formulation 262 CASE( 6 ) ; CALL sbc_blk_mfs ( kt ) ! bulk formulation : MFS for the ocean 240 263 CASE( -1 ) 241 264 CALL sbc_ana ( kt ) ! ESOPA, test ALL the formulations … … 253 276 ! 254 277 CASE( 2 ) ; CALL sbc_ice_lim_2( kt, nsbc ) ! LIM-2 ice model 255 IF( lk_bdy ) CALL bdy_ice_ frs( kt ) ! BDY boundary condition278 IF( lk_bdy ) CALL bdy_ice_lim_2( kt ) ! BDY boundary condition 256 279 ! 257 280 CASE( 3 ) ; CALL sbc_ice_lim ( kt, nsbc ) ! LIM-3 ice model 281 ! 282 CASE( 4 ) ; CALL sbc_ice_cice ( kt, nsbc ) ! CICE ice model 258 283 END SELECT 259 284 … … 327 352 ! 328 353 IF(ln_ctl) THEN ! print mean trends (used for debugging) 329 CALL prt_ctl(tab2d_1=fr_i , clinfo1=' fr_i - : ', mask1=tmask, ovlap=1 ) 330 CALL prt_ctl(tab2d_1=(emp-rnf) , clinfo1=' emp-rnf - : ', mask1=tmask, ovlap=1 ) 331 CALL prt_ctl(tab2d_1=(emps-rnf), clinfo1=' emps-rnf - : ', mask1=tmask, ovlap=1 ) 332 CALL prt_ctl(tab2d_1=qns , clinfo1=' qns - : ', mask1=tmask, ovlap=1 ) 333 CALL prt_ctl(tab2d_1=qsr , clinfo1=' qsr - : ', mask1=tmask, ovlap=1 ) 334 CALL prt_ctl(tab3d_1=tmask , clinfo1=' tmask - : ', mask1=tmask, ovlap=1, kdim=jpk ) 335 CALL prt_ctl(tab3d_1=tn , clinfo1=' sst - : ', mask1=tmask, ovlap=1, kdim=1 ) 336 CALL prt_ctl(tab3d_1=sn , clinfo1=' sss - : ', mask1=tmask, ovlap=1, kdim=1 ) 337 CALL prt_ctl(tab2d_1=utau , clinfo1=' utau - : ', mask1=umask, & 338 & tab2d_2=vtau , clinfo2=' vtau - : ', mask2=vmask, ovlap=1 ) 339 ENDIF 354 CALL prt_ctl(tab2d_1=fr_i , clinfo1=' fr_i - : ', mask1=tmask, ovlap=1 ) 355 CALL prt_ctl(tab2d_1=(emp-rnf) , clinfo1=' emp-rnf - : ', mask1=tmask, ovlap=1 ) 356 CALL prt_ctl(tab2d_1=(emps-rnf) , clinfo1=' emps-rnf - : ', mask1=tmask, ovlap=1 ) 357 CALL prt_ctl(tab2d_1=qns , clinfo1=' qns - : ', mask1=tmask, ovlap=1 ) 358 CALL prt_ctl(tab2d_1=qsr , clinfo1=' qsr - : ', mask1=tmask, ovlap=1 ) 359 CALL prt_ctl(tab3d_1=tmask , clinfo1=' tmask - : ', mask1=tmask, ovlap=1, kdim=jpk ) 360 CALL prt_ctl(tab3d_1=tsn(:,:,:,jp_tem), clinfo1=' sst - : ', mask1=tmask, ovlap=1, kdim=1 ) 361 CALL prt_ctl(tab3d_1=tsn(:,:,:,jp_sal), clinfo1=' sss - : ', mask1=tmask, ovlap=1, kdim=1 ) 362 CALL prt_ctl(tab2d_1=utau , clinfo1=' utau - : ', mask1=umask, & 363 & tab2d_2=vtau , clinfo2=' vtau - : ', mask2=vmask, ovlap=1 ) 364 ENDIF 365 366 IF( kt == nitend ) CALL sbc_final ! Close down surface module if necessary 367 ! 368 IF( nn_timing == 1 ) CALL timing_stop('sbc') 340 369 ! 341 370 END SUBROUTINE sbc 371 372 SUBROUTINE sbc_final 373 !!--------------------------------------------------------------------- 374 !! *** ROUTINE sbc_final *** 375 !!--------------------------------------------------------------------- 376 377 !----------------------------------------------------------------- 378 ! Finalize CICE (if used) 379 !----------------------------------------------------------------- 380 381 IF( nn_ice == 4 ) CALL cice_sbc_final 382 ! 383 END SUBROUTINE sbc_final 342 384 343 385 !!====================================================================== -
trunk/NEMOGCM/NEMO/OPA_SRC/SBC/sbcrnf.F90
r2784 r3294 376 376 ENDIF 377 377 ! 378 rnf(:,:) = 0._wp ! runoff initialisation 378 379 rnf_tsc(:,:,:) = 0._wp ! runoffs temperature & salinty contents initilisation 379 380 ! -
trunk/NEMOGCM/NEMO/OPA_SRC/SBC/sbcssm.F90
r2715 r3294 64 64 ssu_m(:,:) = ub(:,:,1) 65 65 ssv_m(:,:) = vb(:,:,1) 66 sst_m(:,:) = t n(:,:,1)67 sss_m(:,:) = sn(:,:,1)66 sst_m(:,:) = tsn(:,:,1,jp_tem) 67 sss_m(:,:) = tsn(:,:,1,jp_sal) 68 68 ! ! removed inverse barometer ssh when Patm forcing is used (for sea-ice dynamics) 69 69 IF( ln_apr_dyn ) THEN ; ssh_m(:,:) = sshn(:,:) - 0.5 * ( ssh_ib(:,:) + ssh_ibb(:,:) ) … … 104 104 ssu_m(:,:) = zcoef * ub(:,:,1) 105 105 ssv_m(:,:) = zcoef * vb(:,:,1) 106 sst_m(:,:) = zcoef * t n(:,:,1)107 sss_m(:,:) = zcoef * sn(:,:,1)106 sst_m(:,:) = zcoef * tsn(:,:,1,jp_tem) 107 sss_m(:,:) = zcoef * tsn(:,:,1,jp_sal) 108 108 ! ! removed inverse barometer ssh when Patm forcing is used 109 109 IF( ln_apr_dyn ) THEN ; ssh_m(:,:) = zcoef * ( sshn(:,:) - 0.5 * ( ssh_ib(:,:) + ssh_ibb(:,:) ) ) … … 126 126 ssu_m(:,:) = ssu_m(:,:) + ub(:,:,1) 127 127 ssv_m(:,:) = ssv_m(:,:) + vb(:,:,1) 128 sst_m(:,:) = sst_m(:,:) + t n(:,:,1)129 sss_m(:,:) = sss_m(:,:) + sn(:,:,1)128 sst_m(:,:) = sst_m(:,:) + tsn(:,:,1,jp_tem) 129 sss_m(:,:) = sss_m(:,:) + tsn(:,:,1,jp_sal) 130 130 ! ! removed inverse barometer ssh when Patm forcing is used (for sea-ice dynamics) 131 131 IF( ln_apr_dyn ) THEN ; ssh_m(:,:) = ssh_m(:,:) + sshn(:,:) - 0.5 * ( ssh_ib(:,:) + ssh_ibb(:,:) ) -
trunk/NEMOGCM/NEMO/OPA_SRC/SBC/sbcssr.F90
r2715 r3294 21 21 USE lib_mpp ! distribued memory computing library 22 22 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 23 USE timing ! Timing 23 24 24 25 IMPLICIT NONE … … 78 79 NAMELIST/namsbc_ssr/ cn_dir, nn_sstr, nn_sssr, rn_dqdt, rn_deds, sn_sst, sn_sss, ln_sssr_bnd, rn_sssr_bnd 79 80 !!---------------------------------------------------------------------- 81 ! 82 IF( nn_timing == 1 ) CALL timing_start('sbc_ssr') 80 83 ! 81 84 ! ! -------------------- ! … … 201 204 ENDIF 202 205 ! 206 IF( nn_timing == 1 ) CALL timing_stop('sbc_ssr') 207 ! 203 208 END SUBROUTINE sbc_ssr 204 209
Note: See TracChangeset
for help on using the changeset viewer.