Changeset 3690 for trunk/NEMOGCM/NEMO/OPA_SRC/SBC/sbcssr.F90
- Timestamp:
- 2012-11-27T17:51:05+01:00 (11 years ago)
- File:
-
- 1 edited
-
trunk/NEMOGCM/NEMO/OPA_SRC/SBC/sbcssr.F90 (modified) (3 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/NEMOGCM/NEMO/OPA_SRC/SBC/sbcssr.F90
r3558 r3690 27 27 PRIVATE 28 28 29 PUBLIC sbc_ssr ! routine called in sbcmod 29 PUBLIC sbc_ssr ! routine called in sbcmod 30 PUBLIC sbc_ssr_init ! routine called in sbcmod 30 31 31 32 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: erp !: evaporation damping [kg/m2/s] … … 83 84 IF( nn_timing == 1 ) CALL timing_start('sbc_ssr') 84 85 ! 85 ! ! -------------------- !86 IF( kt == nit000 ) THEN ! First call kt=nit000 !87 ! ! -------------------- !88 ! !* set file information89 cn_dir = './' ! directory in which the model is executed90 ! ... default values (NB: frequency positive => hours, negative => months)91 ! ! file ! frequency ! variable ! time intep ! clim ! 'yearly' or ! weights ! rotation !92 ! ! name ! (hours) ! name ! (T/F) ! (T/F) ! 'monthly' ! filename ! pairs !93 sn_sst = FLD_N( 'sst' , 24 , 'sst' , .false. , .false. , 'yearly' , '' , '' )94 sn_sss = FLD_N( 'sss' , -1 , 'sss' , .true. , .false. , 'yearly' , '' , '' )95 96 REWIND ( numnam ) !* read in namlist namflx97 READ( numnam, namsbc_ssr )98 99 IF(lwp) THEN !* control print100 WRITE(numout,*)101 WRITE(numout,*) 'sbc_ssr : SST and/or SSS damping term '102 WRITE(numout,*) '~~~~~~~ '103 WRITE(numout,*) ' Namelist namsbc_ssr :'104 WRITE(numout,*) ' SST restoring term (Yes=1) nn_sstr = ', nn_sstr105 WRITE(numout,*) ' SSS damping term (Yes=1, salt flux) nn_sssr = ', nn_sssr106 WRITE(numout,*) ' (Yes=2, volume flux) '107 WRITE(numout,*) ' dQ/dT (restoring magnitude on SST) rn_dqdt = ', rn_dqdt, ' W/m2/K'108 WRITE(numout,*) ' dE/dS (restoring magnitude on SST) rn_deds = ', rn_deds, ' mm/day'109 WRITE(numout,*) ' flag to bound erp term ln_sssr_bnd = ', ln_sssr_bnd110 WRITE(numout,*) ' ABS(Max./Min.) erp threshold rn_sssr_bnd = ', rn_sssr_bnd, ' mm/day'111 ENDIF112 113 ! Allocate erp and qrp array114 ALLOCATE( qrp(jpi,jpj), erp(jpi,jpj), STAT=ierror )115 IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate erp and qrp array' )116 117 IF( nn_sstr == 1 ) THEN !* set sf_sst structure & allocate arrays118 !119 ALLOCATE( sf_sst(1), STAT=ierror )120 IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sst structure' )121 ALLOCATE( sf_sst(1)%fnow(jpi,jpj,1), STAT=ierror )122 IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sst now array' )123 !124 ! fill sf_sst with sn_sst and control print125 CALL fld_fill( sf_sst, (/ sn_sst /), cn_dir, 'sbc_ssr', 'SST restoring term toward SST data', 'namsbc_ssr' )126 IF( sf_sst(1)%ln_tint ) ALLOCATE( sf_sst(1)%fdta(jpi,jpj,1,2), STAT=ierror )127 IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sst data array' )128 !129 ENDIF130 !131 IF( nn_sssr >= 1 ) THEN ! set sf_sss structure & allocate arrays132 !133 ALLOCATE( sf_sss(1), STAT=ierror )134 IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sss structure' )135 ALLOCATE( sf_sss(1)%fnow(jpi,jpj,1), STAT=ierror )136 IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sss now array' )137 !138 ! fill sf_sss with sn_sss and control print139 CALL fld_fill( sf_sss, (/ sn_sss /), cn_dir, 'sbc_ssr', 'SSS restoring term toward SSS data', 'namsbc_ssr' )140 IF( sf_sss(1)%ln_tint ) ALLOCATE( sf_sss(1)%fdta(jpi,jpj,1,2), STAT=ierror )141 IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sss data array' )142 !143 ENDIF144 !145 ! Initialize qrp and erp if no restoring146 IF( nn_sstr /= 1 ) qrp(:,:) = 0.e0147 IF( nn_sssr /= 1 .OR. nn_sssr /= 2 ) erp(:,:) = 0.e0148 ENDIF149 150 86 IF( nn_sstr + nn_sssr /= 0 ) THEN 151 87 ! … … 208 144 ! 209 145 END SUBROUTINE sbc_ssr 146 147 148 SUBROUTINE sbc_ssr_init 149 !!--------------------------------------------------------------------- 150 !! *** ROUTINE sbc_ssr_init *** 151 !! 152 !! ** Purpose : initialisation of surface damping term 153 !! 154 !! ** Method : - Read namelist namsbc_ssr 155 !! - Read observed SST and/or SSS if required 156 !!--------------------------------------------------------------------- 157 INTEGER :: ji, jj ! dummy loop indices 158 REAL(wp) :: zerp ! local scalar for evaporation damping 159 REAL(wp) :: zqrp ! local scalar for heat flux damping 160 REAL(wp) :: zsrp ! local scalar for unit conversion of rn_deds factor 161 REAL(wp) :: zerp_bnd ! local scalar for unit conversion of rn_epr_max factor 162 INTEGER :: ierror ! return error code 163 !! 164 CHARACTER(len=100) :: cn_dir ! Root directory for location of ssr files 165 TYPE(FLD_N) :: sn_sst, sn_sss ! informations about the fields to be read 166 NAMELIST/namsbc_ssr/ cn_dir, nn_sstr, nn_sssr, rn_dqdt, rn_deds, sn_sst, sn_sss, ln_sssr_bnd, rn_sssr_bnd 167 !!---------------------------------------------------------------------- 168 ! 169 ! !* set file information 170 cn_dir = './' ! directory in which the model is executed 171 ! ... default values (NB: frequency positive => hours, negative => months) 172 ! ! file ! frequency ! variable ! time intep ! clim ! 'yearly' or ! weights ! rotation ! 173 ! ! name ! (hours) ! name ! (T/F) ! (T/F) ! 'monthly' ! filename ! pairs ! 174 sn_sst = FLD_N( 'sst' , 24 , 'sst' , .false. , .false. , 'yearly' , '' , '' ) 175 sn_sss = FLD_N( 'sss' , -1 , 'sss' , .true. , .false. , 'yearly' , '' , '' ) 176 177 REWIND( numnam ) !* read in namlist namflx 178 READ ( numnam, namsbc_ssr ) 179 180 IF(lwp) THEN !* control print 181 WRITE(numout,*) 182 WRITE(numout,*) 'sbc_ssr : SST and/or SSS damping term ' 183 WRITE(numout,*) '~~~~~~~ ' 184 WRITE(numout,*) ' Namelist namsbc_ssr :' 185 WRITE(numout,*) ' SST restoring term (Yes=1) nn_sstr = ', nn_sstr 186 WRITE(numout,*) ' SSS damping term (Yes=1, salt flux) nn_sssr = ', nn_sssr 187 WRITE(numout,*) ' (Yes=2, volume flux) ' 188 WRITE(numout,*) ' dQ/dT (restoring magnitude on SST) rn_dqdt = ', rn_dqdt, ' W/m2/K' 189 WRITE(numout,*) ' dE/dS (restoring magnitude on SST) rn_deds = ', rn_deds, ' mm/day' 190 WRITE(numout,*) ' flag to bound erp term ln_sssr_bnd = ', ln_sssr_bnd 191 WRITE(numout,*) ' ABS(Max./Min.) erp threshold rn_sssr_bnd = ', rn_sssr_bnd, ' mm/day' 192 ENDIF 193 ! 194 ! !* Allocate erp and qrp array 195 ALLOCATE( qrp(jpi,jpj), erp(jpi,jpj), STAT=ierror ) 196 IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate erp and qrp array' ) 197 ! 198 IF( nn_sstr == 1 ) THEN !* set sf_sst structure & allocate arrays 199 ! 200 ALLOCATE( sf_sst(1), STAT=ierror ) 201 IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sst structure' ) 202 ALLOCATE( sf_sst(1)%fnow(jpi,jpj,1), STAT=ierror ) 203 IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sst now array' ) 204 ! 205 ! fill sf_sst with sn_sst and control print 206 CALL fld_fill( sf_sst, (/ sn_sst /), cn_dir, 'sbc_ssr', 'SST restoring term toward SST data', 'namsbc_ssr' ) 207 IF( sf_sst(1)%ln_tint ) ALLOCATE( sf_sst(1)%fdta(jpi,jpj,1,2), STAT=ierror ) 208 IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sst data array' ) 209 ! 210 ENDIF 211 ! 212 IF( nn_sssr >= 1 ) THEN !* set sf_sss structure & allocate arrays 213 ! 214 ALLOCATE( sf_sss(1), STAT=ierror ) 215 IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sss structure' ) 216 ALLOCATE( sf_sss(1)%fnow(jpi,jpj,1), STAT=ierror ) 217 IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sss now array' ) 218 ! 219 ! fill sf_sss with sn_sss and control print 220 CALL fld_fill( sf_sss, (/ sn_sss /), cn_dir, 'sbc_ssr', 'SSS restoring term toward SSS data', 'namsbc_ssr' ) 221 IF( sf_sss(1)%ln_tint ) ALLOCATE( sf_sss(1)%fdta(jpi,jpj,1,2), STAT=ierror ) 222 IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sss data array' ) 223 ! 224 ENDIF 225 ! 226 ! !* Initialize qrp and erp if no restoring 227 IF( nn_sstr /= 1 ) qrp(:,:) = 0._wp 228 IF( nn_sssr /= 1 .OR. nn_sssr /= 2 ) erp(:,:) = 0._wp 229 ! 230 END SUBROUTINE sbc_ssr_init 210 231 211 232 !!======================================================================
Note: See TracChangeset
for help on using the changeset viewer.
