- Timestamp:
- 2017-12-26T17:32:56+01:00 (6 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2017/dev_merge_2017/NEMOGCM/NEMO/SAS_SRC/sbcssm.F90
r9161 r9169 4 4 !! Off-line : interpolation of the physical fields 5 5 !!====================================================================== 6 !! History : 7 !! NEMO 3.4 ! 2012-03 First version by S. Alderson 8 !! ! Heavily derived from Christian's dtadyn routine 9 !! ! in OFF_SRC 10 !!---------------------------------------------------------------------- 11 12 !!---------------------------------------------------------------------- 13 !! sbc_ssm_init : initialization, namelist read, and SAVEs control 14 !! sbc_ssm : Interpolation of the fields 15 !!---------------------------------------------------------------------- 16 USE oce ! ocean dynamics and tracers variables 17 USE c1d ! 1D configuration: lk_c1d 18 USE dom_oce ! ocean domain: variables 19 USE zdf_oce ! ocean vertical physics: variables 20 USE sbc_oce ! surface module: variables 21 USE phycst ! physical constants 22 USE eosbn2 ! equation of state - Brunt Vaisala frequency 23 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 24 USE zpshde ! z-coord. with partial steps: horizontal derivatives 25 USE closea ! for ln_closea 6 !! History : 3.4 ! 2012-03 (S. Alderson) original code 7 !!---------------------------------------------------------------------- 8 9 !!---------------------------------------------------------------------- 10 !! sbc_ssm_init : initialization, namelist read, and SAVEs control 11 !! sbc_ssm : Interpolation of the fields 12 !!---------------------------------------------------------------------- 13 USE oce ! ocean dynamics and tracers variables 14 USE c1d ! 1D configuration: lk_c1d 15 USE dom_oce ! ocean domain: variables 16 USE zdf_oce ! ocean vertical physics: variables 17 USE sbc_oce ! surface module: variables 18 USE phycst ! physical constants 19 USE eosbn2 ! equation of state - Brunt Vaisala frequency 20 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 21 USE zpshde ! z-coord. with partial steps: horizontal derivatives 22 USE closea ! for ln_closea 26 23 ! 27 USE in_out_manager 28 USE iom 29 USE lib_mpp 30 USE prtctl 31 USE fldread 32 USE timing 24 USE in_out_manager ! I/O manager 25 USE iom ! I/O library 26 USE lib_mpp ! distributed memory computing library 27 USE prtctl ! print control 28 USE fldread ! read input fields 29 USE timing ! Timing 33 30 34 31 IMPLICIT NONE … … 38 35 PUBLIC sbc_ssm ! called by sbc 39 36 40 CHARACTER(len=100) :: cn_dir !: Root directory for location of ssm files 41 LOGICAL :: ln_3d_uve !: specify whether input velocity data is 3D 42 LOGICAL :: ln_read_frq !: specify whether we must read frq or not 43 LOGICAL :: l_sasread !: Ice intilisation: read a file (.TRUE.) or anaytical initilaistion in namelist &namsbc_sas 44 LOGICAL :: l_initdone = .false. 37 CHARACTER(len=100) :: cn_dir ! Root directory for location of ssm files 38 LOGICAL :: ln_3d_uve ! specify whether input velocity data is 3D 39 LOGICAL :: ln_read_frq ! specify whether we must read frq or not 40 41 LOGICAL :: l_sasread ! Ice intilisation: =T read a file ; =F anaytical initilaistion 42 LOGICAL :: l_initdone = .false. 45 43 INTEGER :: nfld_3d 46 44 INTEGER :: nfld_2d … … 162 160 !! *** ROUTINE sbc_ssm_init *** 163 161 !! 164 !! ** Purpose : Initialisation of the dynamical data 165 !! ** Method : - read the data namsbc_ssm namelist 166 !! 167 !! ** Action : - read parameters 162 !! ** Purpose : Initialisation of sea surface mean data 168 163 !!---------------------------------------------------------------------- 169 164 INTEGER :: ierr, ierr0, ierr1, ierr2, ierr3 ! return error code … … 175 170 TYPE(FLD_N), ALLOCATABLE, DIMENSION(:) :: slf_3d ! array of namelist information on the fields to read 176 171 TYPE(FLD_N), ALLOCATABLE, DIMENSION(:) :: slf_2d ! array of namelist information on the fields to read 177 TYPE(FLD_N) :: sn_tem, sn_sal ! information about the fields to be read 178 TYPE(FLD_N) :: sn_usp, sn_vsp 179 TYPE(FLD_N) :: sn_ssh, sn_e3t, sn_frq 180 ! 181 NAMELIST/namsbc_sas/l_sasread, cn_dir, ln_3d_uve, ln_read_frq, sn_tem, sn_sal, sn_usp, sn_vsp, sn_ssh, sn_e3t, sn_frq 182 !!---------------------------------------------------------------------- 183 184 IF( ln_rstart .AND. nn_components == jp_iam_sas ) RETURN 185 172 TYPE(FLD_N) :: sn_tem, sn_sal ! information about the fields to be read 173 TYPE(FLD_N) :: sn_usp, sn_vsp 174 TYPE(FLD_N) :: sn_ssh, sn_e3t, sn_frq 175 !! 176 NAMELIST/namsbc_sas/ l_sasread, cn_dir, ln_3d_uve, ln_read_frq, & 177 & sn_tem, sn_sal, sn_usp, sn_vsp, sn_ssh, sn_e3t, sn_frq 178 !!---------------------------------------------------------------------- 179 ! 180 IF( ln_rstart .AND. nn_components == jp_iam_sas ) RETURN 181 ! 182 IF(lwp) THEN 183 WRITE(numout,*) 184 WRITE(numout,*) 'sbc_ssm_init : sea surface mean data initialisation ' 185 WRITE(numout,*) '~~~~~~~~~~~~ ' 186 ENDIF 187 ! 186 188 REWIND( numnam_ref ) ! Namelist namsbc_sas in reference namelist : Input fields 187 189 READ ( numnam_ref, namsbc_sas, IOSTAT = ios, ERR = 901) 188 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_sas in reference namelist', lwp ) 189 190 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_sas in reference namelist', lwp ) 190 191 REWIND( numnam_cfg ) ! Namelist namsbc_sas in configuration namelist : Input fields 191 192 READ ( numnam_cfg, namsbc_sas, IOSTAT = ios, ERR = 902 ) 192 902 IF( ios /= 0 )CALL ctl_nam ( ios , 'namsbc_sas in configuration namelist', lwp )193 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_sas in configuration namelist', lwp ) 193 194 IF(lwm) WRITE ( numond, namsbc_sas ) 194 195 ! ! store namelist information in an array 196 ! ! Control print 197 IF(lwp) THEN 198 WRITE(numout,*) 199 WRITE(numout,*) 'sbc_sas : standalone surface scheme ' 200 WRITE(numout,*) '~~~~~~~~~~~ ' 195 ! 196 IF(lwp) THEN ! Control print 201 197 WRITE(numout,*) ' Namelist namsbc_sas' 202 WRITE(numout,*) ' Initialisation using an input file = ',l_sasread198 WRITE(numout,*) ' Initialisation using an input file l_sasread = ', l_sasread 203 199 WRITE(numout,*) ' Are we supplying a 3D u,v and e3 field ln_3d_uve = ', ln_3d_uve 204 200 WRITE(numout,*) ' Are we reading frq (fraction of qsr absorbed in the 1st T level) ln_read_frq = ', ln_read_frq 205 WRITE(numout,*)206 201 ENDIF 207 202 ! … … 210 205 ! 211 206 IF( ln_apr_dyn ) THEN 212 IF( lwp ) WRITE(numout,*) ' No atmospheric gradient needed with StandAlone Surface scheme'207 IF( lwp ) WRITE(numout,*) ' ==>>> No atmospheric gradient needed with StandAlone Surface scheme' 213 208 ln_apr_dyn = .FALSE. 214 209 ENDIF 215 210 IF( ln_rnf ) THEN 216 IF( lwp ) WRITE(numout,*) ' No runoff needed with StandAlone Surface scheme'211 IF( lwp ) WRITE(numout,*) ' ==>>> No runoff needed with StandAlone Surface scheme' 217 212 ln_rnf = .FALSE. 218 213 ENDIF 219 214 IF( ln_ssr ) THEN 220 IF( lwp ) WRITE(numout,*) ' No surface relaxation needed with StandAlone Surface scheme'215 IF( lwp ) WRITE(numout,*) ' ==>>> No surface relaxation needed with StandAlone Surface scheme' 221 216 ln_ssr = .FALSE. 222 217 ENDIF 223 218 IF( nn_fwb > 0 ) THEN 224 IF( lwp ) WRITE(numout,*) ' No freshwater budget adjustment needed with StandAlone Surface scheme'219 IF( lwp ) WRITE(numout,*) ' ==>>> No freshwater budget adjustment needed with StandAlone Surface scheme' 225 220 nn_fwb = 0 226 221 ENDIF 227 222 IF( ln_closea ) THEN 228 IF( lwp ) WRITE(numout,*) ' No closed seas adjustment needed with StandAlone Surface scheme'223 IF( lwp ) WRITE(numout,*) ' ==>>> No closed seas adjustment needed with StandAlone Surface scheme' 229 224 ln_closea = .false. 230 225 ENDIF 231 IF (l_sasread) THEN 232 ! 233 !! following code is a bit messy, but distinguishes between when u,v are 3d arrays and 234 !! when we have other 3d arrays that we need to read in 235 !! so if a new field is added i.e. jf_new, just give it the next integer in sequence 236 !! for the corresponding dimension (currently if ln_3d_uve is true, 4 for 2d and 3 for 3d, 237 !! alternatively if ln_3d_uve is false, 6 for 2d and 1 for 3d), reset nfld_3d, nfld_2d, 238 !! and the rest of the logic should still work 239 ! 240 jf_tem = 1 ; jf_sal = 2 ; jf_ssh = 3 ; jf_frq = 4 ! default 2D fields index 241 ! 242 IF( ln_3d_uve ) THEN 243 jf_usp = 1 ; jf_vsp = 2 ; jf_e3t = 3 ! define 3D fields index 244 nfld_3d = 2 + COUNT( (/.NOT.ln_linssh/) ) ! number of 3D fields to read 245 nfld_2d = 3 + COUNT( (/ln_read_frq/) ) ! number of 2D fields to read 246 ELSE 247 jf_usp = 4 ; jf_vsp = 5 ; jf_e3t = 6 ; jf_frq = 6 + COUNT( (/.NOT.ln_linssh/) ) ! update 2D fields index 248 nfld_3d = 0 ! no 3D fields to read 249 nfld_2d = 5 + COUNT( (/.NOT.ln_linssh/) ) + COUNT( (/ln_read_frq/) ) ! number of 2D fields to read 250 ENDIF 251 252 IF( nfld_3d > 0 ) THEN 253 ALLOCATE( slf_3d(nfld_3d), STAT=ierr ) ! set slf structure 254 IF( ierr > 0 ) THEN 255 CALL ctl_stop( 'sbc_ssm_init: unable to allocate slf 3d structure' ) ; RETURN 256 ENDIF 257 slf_3d(jf_usp) = sn_usp 258 slf_3d(jf_vsp) = sn_vsp 259 IF( .NOT.ln_linssh ) slf_3d(jf_e3t) = sn_e3t 260 ENDIF 261 262 IF( nfld_2d > 0 ) THEN 263 ALLOCATE( slf_2d(nfld_2d), STAT=ierr ) ! set slf structure 264 IF( ierr > 0 ) THEN 265 CALL ctl_stop( 'sbc_ssm_init: unable to allocate slf 2d structure' ) ; RETURN 266 ENDIF 267 slf_2d(jf_tem) = sn_tem ; slf_2d(jf_sal) = sn_sal ; slf_2d(jf_ssh) = sn_ssh 268 IF( ln_read_frq ) slf_2d(jf_frq) = sn_frq 269 IF( .NOT. ln_3d_uve ) THEN 270 slf_2d(jf_usp) = sn_usp ; slf_2d(jf_vsp) = sn_vsp 271 IF( .NOT.ln_linssh ) slf_2d(jf_e3t) = sn_e3t 272 ENDIF 273 ENDIF 274 ! 275 ierr1 = 0 ! default definition if slf_?d(ifpr)%ln_tint = .false. 276 IF( nfld_3d > 0 ) THEN 277 ALLOCATE( sf_ssm_3d(nfld_3d), STAT=ierr ) ! set sf structure 278 IF( ierr > 0 ) THEN 279 CALL ctl_stop( 'sbc_ssm_init: unable to allocate sf structure' ) ; RETURN 280 ENDIF 281 DO ifpr = 1, nfld_3d 282 ALLOCATE( sf_ssm_3d(ifpr)%fnow(jpi,jpj,jpk) , STAT=ierr0 ) 283 IF( slf_3d(ifpr)%ln_tint ) ALLOCATE( sf_ssm_3d(ifpr)%fdta(jpi,jpj,jpk,2) , STAT=ierr1 ) 284 IF( ierr0 + ierr1 > 0 ) THEN 285 CALL ctl_stop( 'sbc_ssm_init : unable to allocate sf_ssm_3d array structure' ) ; RETURN 286 ENDIF 287 END DO 288 ! ! fill sf with slf_i and control print 289 CALL fld_fill( sf_ssm_3d, slf_3d, cn_dir, 'sbc_ssm_init', '3D Data in file', 'namsbc_ssm' ) 290 ENDIF 291 292 IF( nfld_2d > 0 ) THEN 293 ALLOCATE( sf_ssm_2d(nfld_2d), STAT=ierr ) ! set sf structure 294 IF( ierr > 0 ) THEN 295 CALL ctl_stop( 'sbc_ssm_init: unable to allocate sf 2d structure' ) ; RETURN 296 ENDIF 297 DO ifpr = 1, nfld_2d 298 ALLOCATE( sf_ssm_2d(ifpr)%fnow(jpi,jpj,1) , STAT=ierr0 ) 299 IF( slf_2d(ifpr)%ln_tint ) ALLOCATE( sf_ssm_2d(ifpr)%fdta(jpi,jpj,1,2) , STAT=ierr1 ) 300 IF( ierr0 + ierr1 > 0 ) THEN 301 CALL ctl_stop( 'sbc_ssm_init : unable to allocate sf_ssm_2d array structure' ) ; RETURN 302 ENDIF 303 END DO 304 ! 305 CALL fld_fill( sf_ssm_2d, slf_2d, cn_dir, 'sbc_ssm_init', '2D Data in file', 'namsbc_ssm' ) 306 ENDIF 307 ! 308 ! finally tidy up 309 310 IF( nfld_3d > 0 ) DEALLOCATE( slf_3d, STAT=ierr ) 311 IF( nfld_2d > 0 ) DEALLOCATE( slf_2d, STAT=ierr ) 312 313 ENDIF 314 226 227 ! 228 IF( l_sasread ) THEN ! store namelist information in an array 229 ! 230 !! following code is a bit messy, but distinguishes between when u,v are 3d arrays and 231 !! when we have other 3d arrays that we need to read in 232 !! so if a new field is added i.e. jf_new, just give it the next integer in sequence 233 !! for the corresponding dimension (currently if ln_3d_uve is true, 4 for 2d and 3 for 3d, 234 !! alternatively if ln_3d_uve is false, 6 for 2d and 1 for 3d), reset nfld_3d, nfld_2d, 235 !! and the rest of the logic should still work 236 ! 237 jf_tem = 1 ; jf_ssh = 3 ! default 2D fields index 238 jf_sal = 2 ; jf_frq = 4 ! 239 ! 240 IF( ln_3d_uve ) THEN 241 jf_usp = 1 ; jf_vsp = 2 ; jf_e3t = 3 ! define 3D fields index 242 nfld_3d = 2 + COUNT( (/.NOT.ln_linssh/) ) ! number of 3D fields to read 243 nfld_2d = 3 + COUNT( ( /ln_read_frq/) ) ! number of 2D fields to read 244 ELSE 245 jf_usp = 4 ; jf_e3t = 6 ! update 2D fields index 246 jf_vsp = 5 ; jf_frq = 6 + COUNT( (/.NOT.ln_linssh/) ) 247 ! 248 nfld_3d = 0 ! no 3D fields to read 249 nfld_2d = 5 + COUNT( (/.NOT.ln_linssh/) ) + COUNT( (/ln_read_frq/) ) ! number of 2D fields to read 250 ENDIF 251 ! 252 IF( nfld_3d > 0 ) THEN 253 ALLOCATE( slf_3d(nfld_3d), STAT=ierr ) ! set slf structure 254 IF( ierr > 0 ) THEN 255 CALL ctl_stop( 'sbc_ssm_init: unable to allocate slf 3d structure' ) ; RETURN 256 ENDIF 257 slf_3d(jf_usp) = sn_usp 258 slf_3d(jf_vsp) = sn_vsp 259 IF( .NOT.ln_linssh ) slf_3d(jf_e3t) = sn_e3t 260 ENDIF 261 ! 262 IF( nfld_2d > 0 ) THEN 263 ALLOCATE( slf_2d(nfld_2d), STAT=ierr ) ! set slf structure 264 IF( ierr > 0 ) THEN 265 CALL ctl_stop( 'sbc_ssm_init: unable to allocate slf 2d structure' ) ; RETURN 266 ENDIF 267 slf_2d(jf_tem) = sn_tem ; slf_2d(jf_sal) = sn_sal ; slf_2d(jf_ssh) = sn_ssh 268 IF( ln_read_frq ) slf_2d(jf_frq) = sn_frq 269 IF( .NOT. ln_3d_uve ) THEN 270 slf_2d(jf_usp) = sn_usp ; slf_2d(jf_vsp) = sn_vsp 271 IF( .NOT.ln_linssh ) slf_2d(jf_e3t) = sn_e3t 272 ENDIF 273 ENDIF 274 ! 275 ierr1 = 0 ! default definition if slf_?d(ifpr)%ln_tint = .false. 276 IF( nfld_3d > 0 ) THEN 277 ALLOCATE( sf_ssm_3d(nfld_3d), STAT=ierr ) ! set sf structure 278 IF( ierr > 0 ) THEN 279 CALL ctl_stop( 'sbc_ssm_init: unable to allocate sf structure' ) ; RETURN 280 ENDIF 281 DO ifpr = 1, nfld_3d 282 ALLOCATE( sf_ssm_3d(ifpr)%fnow(jpi,jpj,jpk) , STAT=ierr0 ) 283 IF( slf_3d(ifpr)%ln_tint ) ALLOCATE( sf_ssm_3d(ifpr)%fdta(jpi,jpj,jpk,2) , STAT=ierr1 ) 284 IF( ierr0 + ierr1 > 0 ) THEN 285 CALL ctl_stop( 'sbc_ssm_init : unable to allocate sf_ssm_3d array structure' ) ; RETURN 286 ENDIF 287 END DO 288 ! ! fill sf with slf_i and control print 289 CALL fld_fill( sf_ssm_3d, slf_3d, cn_dir, 'sbc_ssm_init', '3D Data in file', 'namsbc_ssm' ) 290 ENDIF 291 ! 292 IF( nfld_2d > 0 ) THEN 293 ALLOCATE( sf_ssm_2d(nfld_2d), STAT=ierr ) ! set sf structure 294 IF( ierr > 0 ) THEN 295 CALL ctl_stop( 'sbc_ssm_init: unable to allocate sf 2d structure' ) ; RETURN 296 ENDIF 297 DO ifpr = 1, nfld_2d 298 ALLOCATE( sf_ssm_2d(ifpr)%fnow(jpi,jpj,1) , STAT=ierr0 ) 299 IF( slf_2d(ifpr)%ln_tint ) ALLOCATE( sf_ssm_2d(ifpr)%fdta(jpi,jpj,1,2) , STAT=ierr1 ) 300 IF( ierr0 + ierr1 > 0 ) THEN 301 CALL ctl_stop( 'sbc_ssm_init : unable to allocate sf_ssm_2d array structure' ) ; RETURN 302 ENDIF 303 END DO 304 ! 305 CALL fld_fill( sf_ssm_2d, slf_2d, cn_dir, 'sbc_ssm_init', '2D Data in file', 'namsbc_ssm' ) 306 ENDIF 307 ! 308 IF( nfld_3d > 0 ) DEALLOCATE( slf_3d, STAT=ierr ) 309 IF( nfld_2d > 0 ) DEALLOCATE( slf_2d, STAT=ierr ) 310 ! 311 ENDIF 312 ! 315 313 CALL sbc_ssm( nit000 ) ! need to define ss?_m arrays used in iceistate 316 314 l_initdone = .TRUE.
Note: See TracChangeset
for help on using the changeset viewer.
