[782] | 1 | ! |
---|
| 2 | MODULE oasis |
---|
| 3 | ! |
---|
| 4 | ! This module contains subroutines for initialization, sending and receiving |
---|
| 5 | ! towards the coupler OASIS3. It also contains some parameters for the coupling. |
---|
| 6 | ! |
---|
| 7 | ! This module should always be compiled. With the coupler OASIS3 available the cpp key |
---|
| 8 | ! CPP_COUPLE should be set and the entier of this file will then be compiled. |
---|
| 9 | ! In a forced mode CPP_COUPLE should not be defined and the compilation ends before |
---|
| 10 | ! the CONTAINS, without compiling the subroutines. |
---|
| 11 | ! |
---|
| 12 | USE dimphy |
---|
| 13 | USE mod_phys_lmdz_para |
---|
| 14 | USE write_field_phy |
---|
| 15 | |
---|
| 16 | #ifdef CPP_COUPLE |
---|
[1965] | 17 | ! Use of Oasis-MCT coupler |
---|
| 18 | #if defined CPP_OMCT |
---|
| 19 | USE mod_prism |
---|
| 20 | ! Use of Oasis3 coupler |
---|
| 21 | #else |
---|
[782] | 22 | USE mod_prism_proto |
---|
| 23 | USE mod_prism_def_partition_proto |
---|
| 24 | USE mod_prism_get_proto |
---|
| 25 | USE mod_prism_put_proto |
---|
| 26 | #endif |
---|
[1965] | 27 | #endif |
---|
[782] | 28 | |
---|
| 29 | IMPLICIT NONE |
---|
[1279] | 30 | |
---|
| 31 | ! Id for fields sent to ocean |
---|
| 32 | INTEGER, PARAMETER :: ids_tauxxu = 1 |
---|
| 33 | INTEGER, PARAMETER :: ids_tauyyu = 2 |
---|
| 34 | INTEGER, PARAMETER :: ids_tauzzu = 3 |
---|
| 35 | INTEGER, PARAMETER :: ids_tauxxv = 4 |
---|
| 36 | INTEGER, PARAMETER :: ids_tauyyv = 5 |
---|
| 37 | INTEGER, PARAMETER :: ids_tauzzv = 6 |
---|
| 38 | INTEGER, PARAMETER :: ids_windsp = 7 |
---|
| 39 | INTEGER, PARAMETER :: ids_shfice = 8 |
---|
| 40 | INTEGER, PARAMETER :: ids_shfoce = 9 |
---|
| 41 | INTEGER, PARAMETER :: ids_shftot = 10 |
---|
| 42 | INTEGER, PARAMETER :: ids_nsfice = 11 |
---|
| 43 | INTEGER, PARAMETER :: ids_nsfoce = 12 |
---|
| 44 | INTEGER, PARAMETER :: ids_nsftot = 13 |
---|
| 45 | INTEGER, PARAMETER :: ids_dflxdt = 14 |
---|
| 46 | INTEGER, PARAMETER :: ids_totrai = 15 |
---|
| 47 | INTEGER, PARAMETER :: ids_totsno = 16 |
---|
| 48 | INTEGER, PARAMETER :: ids_toteva = 17 |
---|
| 49 | INTEGER, PARAMETER :: ids_icevap = 18 |
---|
| 50 | INTEGER, PARAMETER :: ids_ocevap = 19 |
---|
| 51 | INTEGER, PARAMETER :: ids_calvin = 20 |
---|
| 52 | INTEGER, PARAMETER :: ids_liqrun = 21 |
---|
| 53 | INTEGER, PARAMETER :: ids_runcoa = 22 |
---|
| 54 | INTEGER, PARAMETER :: ids_rivflu = 23 |
---|
| 55 | INTEGER, PARAMETER :: ids_atmco2 = 24 |
---|
| 56 | INTEGER, PARAMETER :: ids_taumod = 25 |
---|
[2545] | 57 | INTEGER, PARAMETER :: maxsend = 25 ! Maximum number of fields to send |
---|
[1279] | 58 | |
---|
| 59 | ! Id for fields received from ocean |
---|
| 60 | INTEGER, PARAMETER :: idr_sisutw = 1 |
---|
| 61 | INTEGER, PARAMETER :: idr_icecov = 2 |
---|
| 62 | INTEGER, PARAMETER :: idr_icealw = 3 |
---|
| 63 | INTEGER, PARAMETER :: idr_icetem = 4 |
---|
| 64 | INTEGER, PARAMETER :: idr_curenx = 5 |
---|
| 65 | INTEGER, PARAMETER :: idr_cureny = 6 |
---|
| 66 | INTEGER, PARAMETER :: idr_curenz = 7 |
---|
| 67 | INTEGER, PARAMETER :: idr_oceco2 = 8 |
---|
| 68 | INTEGER, PARAMETER :: maxrecv = 8 ! Maximum number of fields to receive |
---|
| 69 | |
---|
[782] | 70 | |
---|
[1279] | 71 | TYPE, PUBLIC :: FLD_CPL ! Type for coupling field information |
---|
| 72 | CHARACTER(len = 8) :: name ! Name of the coupling field |
---|
| 73 | LOGICAL :: action ! To be exchanged or not |
---|
| 74 | INTEGER :: nid ! Id of the field |
---|
| 75 | END TYPE FLD_CPL |
---|
[782] | 76 | |
---|
[1279] | 77 | TYPE(FLD_CPL), DIMENSION(maxsend), SAVE, PUBLIC :: infosend ! Information for sending coupling fields |
---|
| 78 | TYPE(FLD_CPL), DIMENSION(maxrecv), SAVE, PUBLIC :: inforecv ! Information for receiving coupling fields |
---|
| 79 | |
---|
| 80 | LOGICAL,SAVE :: cpl_current |
---|
| 81 | !$OMP THREADPRIVATE(cpl_current) |
---|
[782] | 82 | |
---|
| 83 | #ifdef CPP_COUPLE |
---|
| 84 | |
---|
| 85 | CONTAINS |
---|
| 86 | |
---|
| 87 | SUBROUTINE inicma |
---|
| 88 | !************************************************************************************ |
---|
| 89 | !**** *INICMA* - Initialize coupled mode communication for atmosphere |
---|
| 90 | ! and exchange some initial information with Oasis |
---|
| 91 | ! |
---|
| 92 | ! Rewrite to take the PRISM/psmile library into account |
---|
| 93 | ! LF 09/2003 |
---|
| 94 | ! |
---|
[1067] | 95 | USE IOIPSL |
---|
[996] | 96 | USE surface_data, ONLY : version_ocean |
---|
[1279] | 97 | USE carbon_cycle_mod, ONLY : carbon_cycle_cpl |
---|
[2054] | 98 | #ifdef CPP_XIOS |
---|
| 99 | USE wxios, ONLY : wxios_context_init |
---|
| 100 | #endif |
---|
[2311] | 101 | USE print_control_mod, ONLY: lunout |
---|
[2371] | 102 | USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat |
---|
[1279] | 103 | |
---|
[782] | 104 | ! Local variables |
---|
| 105 | !************************************************************************************ |
---|
| 106 | INTEGER :: comp_id |
---|
| 107 | INTEGER :: ierror, il_commlocal |
---|
| 108 | INTEGER :: il_part_id |
---|
| 109 | INTEGER, DIMENSION(3) :: ig_paral |
---|
| 110 | INTEGER, DIMENSION(2) :: il_var_nodims |
---|
| 111 | INTEGER, DIMENSION(4) :: il_var_actual_shape |
---|
| 112 | INTEGER :: il_var_type |
---|
| 113 | INTEGER :: jf |
---|
| 114 | CHARACTER (len = 6) :: clmodnam |
---|
| 115 | CHARACTER (len = 20) :: modname = 'inicma' |
---|
| 116 | CHARACTER (len = 80) :: abort_message |
---|
[1997] | 117 | LOGICAL, SAVE :: cpl_current_omp |
---|
[782] | 118 | |
---|
| 119 | !* 1. Initializations |
---|
| 120 | ! --------------- |
---|
| 121 | !************************************************************************************ |
---|
[1279] | 122 | WRITE(lunout,*) ' ' |
---|
| 123 | WRITE(lunout,*) ' ' |
---|
| 124 | WRITE(lunout,*) ' ROUTINE INICMA' |
---|
| 125 | WRITE(lunout,*) ' **************' |
---|
| 126 | WRITE(lunout,*) ' ' |
---|
| 127 | WRITE(lunout,*) ' ' |
---|
[782] | 128 | |
---|
| 129 | ! |
---|
| 130 | ! Define the model name |
---|
| 131 | ! |
---|
[2054] | 132 | clmodnam = 'LMDZ' ! as in $NBMODEL in Cpl/Nam/namcouple.tmp |
---|
[1067] | 133 | |
---|
[1279] | 134 | |
---|
[782] | 135 | !************************************************************************************ |
---|
[1067] | 136 | ! Define if coupling ocean currents or not |
---|
| 137 | !************************************************************************************ |
---|
| 138 | !$OMP MASTER |
---|
| 139 | cpl_current_omp = .FALSE. |
---|
| 140 | CALL getin('cpl_current', cpl_current_omp) |
---|
| 141 | !$OMP END MASTER |
---|
| 142 | !$OMP BARRIER |
---|
| 143 | cpl_current = cpl_current_omp |
---|
[1279] | 144 | WRITE(lunout,*) 'Couple ocean currents, cpl_current = ',cpl_current |
---|
[1067] | 145 | |
---|
| 146 | !************************************************************************************ |
---|
[1279] | 147 | ! Define coupling variables |
---|
| 148 | !************************************************************************************ |
---|
| 149 | |
---|
| 150 | ! Atmospheric variables to send |
---|
| 151 | |
---|
| 152 | !$OMP MASTER |
---|
| 153 | infosend(:)%action = .FALSE. |
---|
| 154 | |
---|
| 155 | infosend(ids_tauxxu)%action = .TRUE. ; infosend(ids_tauxxu)%name = 'COTAUXXU' |
---|
| 156 | infosend(ids_tauyyu)%action = .TRUE. ; infosend(ids_tauyyu)%name = 'COTAUYYU' |
---|
| 157 | infosend(ids_tauzzu)%action = .TRUE. ; infosend(ids_tauzzu)%name = 'COTAUZZU' |
---|
| 158 | infosend(ids_tauxxv)%action = .TRUE. ; infosend(ids_tauxxv)%name = 'COTAUXXV' |
---|
| 159 | infosend(ids_tauyyv)%action = .TRUE. ; infosend(ids_tauyyv)%name = 'COTAUYYV' |
---|
| 160 | infosend(ids_tauzzv)%action = .TRUE. ; infosend(ids_tauzzv)%name = 'COTAUZZV' |
---|
| 161 | infosend(ids_windsp)%action = .TRUE. ; infosend(ids_windsp)%name = 'COWINDSP' |
---|
| 162 | infosend(ids_shfice)%action = .TRUE. ; infosend(ids_shfice)%name = 'COSHFICE' |
---|
| 163 | infosend(ids_nsfice)%action = .TRUE. ; infosend(ids_nsfice)%name = 'CONSFICE' |
---|
| 164 | infosend(ids_dflxdt)%action = .TRUE. ; infosend(ids_dflxdt)%name = 'CODFLXDT' |
---|
| 165 | infosend(ids_calvin)%action = .TRUE. ; infosend(ids_calvin)%name = 'COCALVIN' |
---|
| 166 | |
---|
| 167 | IF (version_ocean=='nemo') THEN |
---|
| 168 | infosend(ids_shftot)%action = .TRUE. ; infosend(ids_shftot)%name = 'COQSRMIX' |
---|
| 169 | infosend(ids_nsftot)%action = .TRUE. ; infosend(ids_nsftot)%name = 'COQNSMIX' |
---|
| 170 | infosend(ids_totrai)%action = .TRUE. ; infosend(ids_totrai)%name = 'COTOTRAI' |
---|
| 171 | infosend(ids_totsno)%action = .TRUE. ; infosend(ids_totsno)%name = 'COTOTSNO' |
---|
| 172 | infosend(ids_toteva)%action = .TRUE. ; infosend(ids_toteva)%name = 'COTOTEVA' |
---|
| 173 | infosend(ids_icevap)%action = .TRUE. ; infosend(ids_icevap)%name = 'COICEVAP' |
---|
| 174 | infosend(ids_liqrun)%action = .TRUE. ; infosend(ids_liqrun)%name = 'COLIQRUN' |
---|
| 175 | infosend(ids_taumod)%action = .TRUE. ; infosend(ids_taumod)%name = 'COTAUMOD' |
---|
| 176 | IF (carbon_cycle_cpl) THEN |
---|
| 177 | infosend(ids_atmco2)%action = .TRUE. ; infosend(ids_atmco2)%name = 'COATMCO2' |
---|
| 178 | ENDIF |
---|
| 179 | |
---|
| 180 | ELSE IF (version_ocean=='opa8') THEN |
---|
| 181 | infosend(ids_shfoce)%action = .TRUE. ; infosend(ids_shfoce)%name = 'COSHFOCE' |
---|
| 182 | infosend(ids_nsfoce)%action = .TRUE. ; infosend(ids_nsfoce)%name = 'CONSFOCE' |
---|
| 183 | infosend(ids_icevap)%action = .TRUE. ; infosend(ids_icevap)%name = 'COTFSICE' |
---|
| 184 | infosend(ids_ocevap)%action = .TRUE. ; infosend(ids_ocevap)%name = 'COTFSOCE' |
---|
| 185 | infosend(ids_totrai)%action = .TRUE. ; infosend(ids_totrai)%name = 'COTOLPSU' |
---|
| 186 | infosend(ids_totsno)%action = .TRUE. ; infosend(ids_totsno)%name = 'COTOSPSU' |
---|
| 187 | infosend(ids_runcoa)%action = .TRUE. ; infosend(ids_runcoa)%name = 'CORUNCOA' |
---|
| 188 | infosend(ids_rivflu)%action = .TRUE. ; infosend(ids_rivflu)%name = 'CORIVFLU' |
---|
| 189 | ENDIF |
---|
| 190 | |
---|
| 191 | ! Oceanic variables to receive |
---|
| 192 | |
---|
| 193 | inforecv(:)%action = .FALSE. |
---|
| 194 | |
---|
| 195 | inforecv(idr_sisutw)%action = .TRUE. ; inforecv(idr_sisutw)%name = 'SISUTESW' |
---|
| 196 | inforecv(idr_icecov)%action = .TRUE. ; inforecv(idr_icecov)%name = 'SIICECOV' |
---|
| 197 | inforecv(idr_icealw)%action = .TRUE. ; inforecv(idr_icealw)%name = 'SIICEALW' |
---|
| 198 | inforecv(idr_icetem)%action = .TRUE. ; inforecv(idr_icetem)%name = 'SIICTEMW' |
---|
| 199 | |
---|
| 200 | IF (cpl_current ) THEN |
---|
| 201 | inforecv(idr_curenx)%action = .TRUE. ; inforecv(idr_curenx)%name = 'CURRENTX' |
---|
| 202 | inforecv(idr_cureny)%action = .TRUE. ; inforecv(idr_cureny)%name = 'CURRENTY' |
---|
| 203 | inforecv(idr_curenz)%action = .TRUE. ; inforecv(idr_curenz)%name = 'CURRENTZ' |
---|
| 204 | ENDIF |
---|
| 205 | |
---|
| 206 | IF (carbon_cycle_cpl ) THEN |
---|
| 207 | inforecv(idr_oceco2)%action = .TRUE. ; inforecv(idr_oceco2)%name = 'SICO2FLX' |
---|
| 208 | ENDIF |
---|
| 209 | |
---|
| 210 | !************************************************************************************ |
---|
[782] | 211 | ! Here we go: psmile initialisation |
---|
| 212 | !************************************************************************************ |
---|
| 213 | IF (is_sequential) THEN |
---|
| 214 | CALL prism_init_comp_proto (comp_id, clmodnam, ierror) |
---|
| 215 | |
---|
| 216 | IF (ierror .NE. PRISM_Ok) THEN |
---|
| 217 | abort_message=' Probleme init dans prism_init_comp ' |
---|
[2311] | 218 | CALL abort_physic(modname,abort_message,1) |
---|
[782] | 219 | ELSE |
---|
[1279] | 220 | WRITE(lunout,*) 'inicma : init psmile ok ' |
---|
[782] | 221 | ENDIF |
---|
| 222 | ENDIF |
---|
| 223 | |
---|
| 224 | CALL prism_get_localcomm_proto (il_commlocal, ierror) |
---|
| 225 | !************************************************************************************ |
---|
| 226 | ! Domain decomposition |
---|
| 227 | !************************************************************************************ |
---|
| 228 | ig_paral(1) = 1 ! apple partition for // |
---|
[2346] | 229 | ig_paral(2) = (jj_begin-1)*nbp_lon+ii_begin-1 ! offset |
---|
| 230 | ig_paral(3) = (jj_end*nbp_lon+ii_end) - (jj_begin*nbp_lon+ii_begin) + 1 |
---|
[782] | 231 | |
---|
[2346] | 232 | IF (mpi_rank==mpi_size-1) ig_paral(3)=ig_paral(3)+nbp_lon-1 |
---|
[1279] | 233 | WRITE(lunout,*) mpi_rank,'ig_paral--->',ig_paral(2),ig_paral(3) |
---|
[782] | 234 | |
---|
| 235 | ierror=PRISM_Ok |
---|
| 236 | CALL prism_def_partition_proto (il_part_id, ig_paral, ierror) |
---|
| 237 | |
---|
| 238 | IF (ierror .NE. PRISM_Ok) THEN |
---|
| 239 | abort_message=' Probleme dans prism_def_partition ' |
---|
[2311] | 240 | CALL abort_physic(modname,abort_message,1) |
---|
[782] | 241 | ELSE |
---|
[1279] | 242 | WRITE(lunout,*) 'inicma : decomposition domaine psmile ok ' |
---|
[782] | 243 | ENDIF |
---|
| 244 | |
---|
| 245 | il_var_nodims(1) = 2 |
---|
| 246 | il_var_nodims(2) = 1 |
---|
| 247 | |
---|
| 248 | il_var_actual_shape(1) = 1 |
---|
[2346] | 249 | il_var_actual_shape(2) = nbp_lon |
---|
[782] | 250 | il_var_actual_shape(3) = 1 |
---|
[2346] | 251 | il_var_actual_shape(4) = nbp_lat |
---|
[782] | 252 | |
---|
| 253 | il_var_type = PRISM_Real |
---|
| 254 | |
---|
| 255 | !************************************************************************************ |
---|
[1279] | 256 | ! Oceanic Fields to receive |
---|
| 257 | ! Loop over all possible variables |
---|
[782] | 258 | !************************************************************************************ |
---|
[1279] | 259 | DO jf=1, maxrecv |
---|
| 260 | IF (inforecv(jf)%action) THEN |
---|
| 261 | CALL prism_def_var_proto(inforecv(jf)%nid, inforecv(jf)%name, il_part_id, & |
---|
| 262 | il_var_nodims, PRISM_In, il_var_actual_shape, il_var_type, & |
---|
| 263 | ierror) |
---|
| 264 | IF (ierror .NE. PRISM_Ok) THEN |
---|
| 265 | WRITE(lunout,*) 'inicma : Problem with prism_def_var_proto for field : ',& |
---|
| 266 | inforecv(jf)%name |
---|
| 267 | abort_message=' Problem in call to prism_def_var_proto for fields to receive' |
---|
[2311] | 268 | CALL abort_physic(modname,abort_message,1) |
---|
[1279] | 269 | ENDIF |
---|
[782] | 270 | ENDIF |
---|
| 271 | END DO |
---|
[1279] | 272 | |
---|
[782] | 273 | !************************************************************************************ |
---|
[1279] | 274 | ! Atmospheric Fields to send |
---|
| 275 | ! Loop over all possible variables |
---|
[782] | 276 | !************************************************************************************ |
---|
[1279] | 277 | DO jf=1,maxsend |
---|
| 278 | IF (infosend(jf)%action) THEN |
---|
| 279 | CALL prism_def_var_proto(infosend(jf)%nid, infosend(jf)%name, il_part_id, & |
---|
| 280 | il_var_nodims, PRISM_Out, il_var_actual_shape, il_var_type, & |
---|
| 281 | ierror) |
---|
| 282 | IF (ierror .NE. PRISM_Ok) THEN |
---|
| 283 | WRITE(lunout,*) 'inicma : Problem with prism_def_var_proto for field : ',& |
---|
| 284 | infosend(jf)%name |
---|
| 285 | abort_message=' Problem in call to prism_def_var_proto for fields to send' |
---|
[2311] | 286 | CALL abort_physic(modname,abort_message,1) |
---|
[1279] | 287 | ENDIF |
---|
[782] | 288 | ENDIF |
---|
| 289 | END DO |
---|
[1279] | 290 | |
---|
[782] | 291 | !************************************************************************************ |
---|
| 292 | ! End definition |
---|
| 293 | !************************************************************************************ |
---|
| 294 | CALL prism_enddef_proto(ierror) |
---|
| 295 | IF (ierror .NE. PRISM_Ok) THEN |
---|
[1279] | 296 | abort_message=' Problem in call to prism_endef_proto' |
---|
[2311] | 297 | CALL abort_physic(modname,abort_message,1) |
---|
[782] | 298 | ELSE |
---|
[1279] | 299 | WRITE(lunout,*) 'inicma : endef psmile ok ' |
---|
[782] | 300 | ENDIF |
---|
[1279] | 301 | |
---|
[2054] | 302 | #ifdef CPP_XIOS |
---|
| 303 | CALL wxios_context_init() |
---|
| 304 | #endif |
---|
| 305 | |
---|
[1279] | 306 | !$OMP END MASTER |
---|
[782] | 307 | |
---|
| 308 | END SUBROUTINE inicma |
---|
| 309 | |
---|
| 310 | ! |
---|
| 311 | !************************************************************************************ |
---|
| 312 | ! |
---|
| 313 | |
---|
| 314 | SUBROUTINE fromcpl(ktime, tab_get) |
---|
| 315 | ! ====================================================================== |
---|
| 316 | ! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine reads the SST |
---|
| 317 | ! and Sea-Ice provided by the coupler. Adaptation to psmile library |
---|
| 318 | !====================================================================== |
---|
| 319 | ! |
---|
[2311] | 320 | USE print_control_mod, ONLY: lunout |
---|
[2371] | 321 | USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat |
---|
[782] | 322 | ! Input arguments |
---|
| 323 | !************************************************************************************ |
---|
| 324 | INTEGER, INTENT(IN) :: ktime |
---|
| 325 | |
---|
| 326 | ! Output arguments |
---|
| 327 | !************************************************************************************ |
---|
[2346] | 328 | REAL, DIMENSION(nbp_lon, jj_nb,maxrecv), INTENT(OUT) :: tab_get |
---|
[782] | 329 | |
---|
| 330 | ! Local variables |
---|
| 331 | !************************************************************************************ |
---|
| 332 | INTEGER :: ierror, i |
---|
| 333 | INTEGER :: istart,iend |
---|
| 334 | CHARACTER (len = 20) :: modname = 'fromcpl' |
---|
| 335 | CHARACTER (len = 80) :: abort_message |
---|
[2346] | 336 | REAL, DIMENSION(nbp_lon*jj_nb) :: field |
---|
[782] | 337 | |
---|
| 338 | !************************************************************************************ |
---|
[1279] | 339 | WRITE (lunout,*) ' ' |
---|
| 340 | WRITE (lunout,*) 'Fromcpl: Reading fields from CPL, ktime=',ktime |
---|
| 341 | WRITE (lunout,*) ' ' |
---|
[782] | 342 | |
---|
| 343 | istart=ii_begin |
---|
[2429] | 344 | IF (is_south_pole_dyn) THEN |
---|
[2346] | 345 | iend=(jj_end-jj_begin)*nbp_lon+nbp_lon |
---|
[782] | 346 | ELSE |
---|
[2346] | 347 | iend=(jj_end-jj_begin)*nbp_lon+ii_end |
---|
[782] | 348 | ENDIF |
---|
| 349 | |
---|
[1279] | 350 | DO i = 1, maxrecv |
---|
[1965] | 351 | IF (inforecv(i)%action .AND. inforecv(i)%nid .NE. -1) THEN |
---|
[1279] | 352 | field(:) = -99999. |
---|
| 353 | CALL prism_get_proto(inforecv(i)%nid, ktime, field(istart:iend), ierror) |
---|
[2346] | 354 | tab_get(:,:,i) = RESHAPE(field(:),(/nbp_lon,jj_nb/)) |
---|
[782] | 355 | |
---|
[1279] | 356 | IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Recvd .AND. & |
---|
| 357 | ierror.NE.PRISM_FromRest & |
---|
| 358 | .AND. ierror.NE.PRISM_Input .AND. ierror.NE.PRISM_RecvOut & |
---|
| 359 | .AND. ierror.NE.PRISM_FromRestOut) THEN |
---|
| 360 | WRITE (lunout,*) 'Error with receiving filed : ', inforecv(i)%name, ktime |
---|
| 361 | abort_message=' Problem in prism_get_proto ' |
---|
[2311] | 362 | CALL abort_physic(modname,abort_message,1) |
---|
[1279] | 363 | ENDIF |
---|
| 364 | ENDIF |
---|
[782] | 365 | END DO |
---|
| 366 | |
---|
| 367 | |
---|
| 368 | END SUBROUTINE fromcpl |
---|
| 369 | |
---|
| 370 | ! |
---|
| 371 | !************************************************************************************ |
---|
| 372 | ! |
---|
| 373 | |
---|
| 374 | SUBROUTINE intocpl(ktime, last, tab_put) |
---|
| 375 | ! ====================================================================== |
---|
| 376 | ! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine provides the |
---|
| 377 | ! atmospheric coupling fields to the coupler with the psmile library. |
---|
| 378 | ! IF last time step, writes output fields to binary files. |
---|
| 379 | ! ====================================================================== |
---|
| 380 | ! |
---|
| 381 | ! |
---|
[2311] | 382 | USE print_control_mod, ONLY: lunout |
---|
[2371] | 383 | USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat |
---|
[782] | 384 | ! Input arguments |
---|
| 385 | !************************************************************************************ |
---|
[1279] | 386 | INTEGER, INTENT(IN) :: ktime |
---|
| 387 | LOGICAL, INTENT(IN) :: last |
---|
[2346] | 388 | REAL, DIMENSION(nbp_lon, jj_nb, maxsend), INTENT(IN) :: tab_put |
---|
[782] | 389 | |
---|
| 390 | ! Local variables |
---|
| 391 | !************************************************************************************ |
---|
[987] | 392 | LOGICAL :: checkout |
---|
| 393 | INTEGER :: istart,iend |
---|
| 394 | INTEGER :: wstart,wend |
---|
| 395 | INTEGER :: ierror, i |
---|
[2346] | 396 | REAL, DIMENSION(nbp_lon*jj_nb) :: field |
---|
[987] | 397 | CHARACTER (len = 20),PARAMETER :: modname = 'intocpl' |
---|
| 398 | CHARACTER (len = 80) :: abort_message |
---|
[782] | 399 | |
---|
| 400 | !************************************************************************************ |
---|
[987] | 401 | checkout=.FALSE. |
---|
[782] | 402 | |
---|
[1279] | 403 | WRITE(lunout,*) ' ' |
---|
| 404 | WRITE(lunout,*) 'Intocpl: sending fields to CPL, ktime= ', ktime |
---|
| 405 | WRITE(lunout,*) 'last = ', last |
---|
| 406 | WRITE(lunout,*) |
---|
[782] | 407 | |
---|
| 408 | |
---|
| 409 | istart=ii_begin |
---|
[2429] | 410 | IF (is_south_pole_dyn) THEN |
---|
[2346] | 411 | iend=(jj_end-jj_begin)*nbp_lon+nbp_lon |
---|
[782] | 412 | ELSE |
---|
[2346] | 413 | iend=(jj_end-jj_begin)*nbp_lon+ii_end |
---|
[782] | 414 | ENDIF |
---|
| 415 | |
---|
| 416 | IF (checkout) THEN |
---|
| 417 | wstart=istart |
---|
| 418 | wend=iend |
---|
[2429] | 419 | IF (is_north_pole_dyn) wstart=istart+nbp_lon-1 |
---|
| 420 | IF (is_south_pole_dyn) wend=iend-nbp_lon+1 |
---|
[782] | 421 | |
---|
[1279] | 422 | DO i = 1, maxsend |
---|
| 423 | IF (infosend(i)%action) THEN |
---|
[2346] | 424 | field = RESHAPE(tab_put(:,:,i),(/nbp_lon*jj_nb/)) |
---|
[1279] | 425 | CALL writefield_phy(infosend(i)%name,field(wstart:wend),1) |
---|
| 426 | END IF |
---|
| 427 | END DO |
---|
| 428 | END IF |
---|
| 429 | |
---|
[782] | 430 | !************************************************************************************ |
---|
| 431 | ! PRISM_PUT |
---|
| 432 | !************************************************************************************ |
---|
| 433 | |
---|
[1279] | 434 | DO i = 1, maxsend |
---|
[1965] | 435 | IF (infosend(i)%action .AND. infosend(i)%nid .NE. -1 ) THEN |
---|
[2346] | 436 | field = RESHAPE(tab_put(:,:,i),(/nbp_lon*jj_nb/)) |
---|
[1279] | 437 | CALL prism_put_proto(infosend(i)%nid, ktime, field(istart:iend), ierror) |
---|
| 438 | |
---|
| 439 | IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Sent .AND. ierror.NE.PRISM_ToRest & |
---|
| 440 | .AND. ierror.NE.PRISM_LocTrans .AND. ierror.NE.PRISM_Output .AND. & |
---|
| 441 | ierror.NE.PRISM_SentOut .AND. ierror.NE.PRISM_ToRestOut) THEN |
---|
| 442 | WRITE (lunout,*) 'Error with sending field :', infosend(i)%name, ktime |
---|
| 443 | abort_message=' Problem in prism_put_proto ' |
---|
[2311] | 444 | CALL abort_physic(modname,abort_message,1) |
---|
[1279] | 445 | ENDIF |
---|
| 446 | ENDIF |
---|
[782] | 447 | END DO |
---|
| 448 | |
---|
| 449 | !************************************************************************************ |
---|
| 450 | ! Finalize PSMILE for the case is_sequential, if parallel finalization is done |
---|
| 451 | ! from Finalize_parallel in dyn3dpar/parallel.F90 |
---|
| 452 | !************************************************************************************ |
---|
| 453 | |
---|
| 454 | IF (last) THEN |
---|
| 455 | IF (is_sequential) THEN |
---|
| 456 | CALL prism_terminate_proto(ierror) |
---|
| 457 | IF (ierror .NE. PRISM_Ok) THEN |
---|
[1279] | 458 | abort_message=' Problem in prism_terminate_proto ' |
---|
[2311] | 459 | CALL abort_physic(modname,abort_message,1) |
---|
[782] | 460 | ENDIF |
---|
| 461 | ENDIF |
---|
| 462 | ENDIF |
---|
| 463 | |
---|
| 464 | |
---|
| 465 | END SUBROUTINE intocpl |
---|
| 466 | |
---|
| 467 | #endif |
---|
| 468 | |
---|
| 469 | END MODULE oasis |
---|