Context Navigation

oasis.F90 @ 3628

Last change on this file since 3628 was 3628, checked in by lguez, 4 years ago
If the ocean skin parameterization is working actively (`activate_ocean_skin == 2`) and we are coupled to the ocean then send ocean-air interface salinity to the ocean. New dummy argument `s_int` of procedures `ocean_cpl_noice` and `cpl_send_ocean_fields`. We can only send interface salinity from the previous time-step since communication with the ocean is before the call to bulk_flux. So make `s_int` a state variable: move `s_int` from `phys_output_var_mod` to `phys_state_var_mod`. Still, we only read `s_int` from startphy, define it before the call to `surf_ocean` and write it to restartphy if `activate_ocean_skin == 2` and `type_ocean == 'couple'`. In procedure `pbl_surface`, for clarity, move the definition of output variables `t_int`, dter, dser, tkt, tks, rf, taur to `missing_val` to after the call to `surf_ocean`, with the definition of `s_int`, `ds_ns`, `dt_ns` to `missing_val`. This does not change anything for `t_int`, dter, dser, tkt, tks, rf, taur. In `pbl_surface_newfrac`, we choose to set `s_int` to 35 for an appearing ocean point, this is questionable. In `surf_ocean`, change the intent of `s_int` from out to inout.
Property copyright set to Name of program: LMDZ Creation date: 1984 Version: LMDZ5 License: CeCILL version 2 Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539 See the license file in the root directory Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 20.8 KB

Rev	Line
[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
[2872]	57	INTEGER, PARAMETER :: ids_qraioc = 26
	58	INTEGER, PARAMETER :: ids_qsnooc = 27
	59	INTEGER, PARAMETER :: ids_qraiic = 28
	60	INTEGER, PARAMETER :: ids_qsnoic = 29
[3628]	61	INTEGER, PARAMETER :: ids_t_int = 30, ids_s_int = 31
[1279]	62
[3628]	63	INTEGER, PARAMETER :: maxsend = 31 ! Maximum number of fields to send
[3627]	64
[1279]	65	! Id for fields received from ocean
[3627]	66
[1279]	67	INTEGER, PARAMETER :: idr_sisutw = 1
	68	INTEGER, PARAMETER :: idr_icecov = 2
	69	INTEGER, PARAMETER :: idr_icealw = 3
	70	INTEGER, PARAMETER :: idr_icetem = 4
	71	INTEGER, PARAMETER :: idr_curenx = 5
	72	INTEGER, PARAMETER :: idr_cureny = 6
	73	INTEGER, PARAMETER :: idr_curenz = 7
	74	INTEGER, PARAMETER :: idr_oceco2 = 8
[3627]	75
	76	INTEGER, PARAMETER :: idr_sss = 9
	77	! bulk salinity of the surface layer of the ocean, in ppt
	78
	79	INTEGER, PARAMETER :: maxrecv = 9 ! Maximum number of fields to receive
[1279]	80
[782]	81
[1279]	82	TYPE, PUBLIC :: FLD_CPL ! Type for coupling field information
	83	CHARACTER(len = 8) :: name ! Name of the coupling field
	84	LOGICAL :: action ! To be exchanged or not
	85	INTEGER :: nid ! Id of the field
	86	END TYPE FLD_CPL
[782]	87
[1279]	88	TYPE(FLD_CPL), DIMENSION(maxsend), SAVE, PUBLIC :: infosend ! Information for sending coupling fields
[2916]	89	!$OMP THREADPRIVATE(infosend)
[1279]	90	TYPE(FLD_CPL), DIMENSION(maxrecv), SAVE, PUBLIC :: inforecv ! Information for receiving coupling fields
[2916]	91	!$OMP THREADPRIVATE(inforecv)
[1279]	92
	93	LOGICAL,SAVE :: cpl_current
	94	!$OMP THREADPRIVATE(cpl_current)
[782]	95
	96	#ifdef CPP_COUPLE
	97
	98	CONTAINS
	99
	100	SUBROUTINE inicma
	101	!************************************************************************************
	102	!**** INICMA - Initialize coupled mode communication for atmosphere
	103	! and exchange some initial information with Oasis
	104	!
	105	! Rewrite to take the PRISM/psmile library into account
	106	! LF 09/2003
	107	!
[1067]	108	USE IOIPSL
[996]	109	USE surface_data, ONLY : version_ocean
[1279]	110	USE carbon_cycle_mod, ONLY : carbon_cycle_cpl
[2054]	111	#ifdef CPP_XIOS
	112	USE wxios, ONLY : wxios_context_init
[3605]	113	USE xios
[2054]	114	#endif
[2311]	115	USE print_control_mod, ONLY: lunout
[3605]	116	USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, grid_type, unstructured, regular_lonlat
	117	USE geometry_mod, ONLY: ind_cell_glo
	118	USE mod_phys_lmdz_mpi_data, ONLY: klon_mpi_para_nb
	119
[1279]	120
[3605]	121
[782]	122	! Local variables
	123	!************************************************************************************
	124	INTEGER :: comp_id
	125	INTEGER :: ierror, il_commlocal
	126	INTEGER :: il_part_id
[3605]	127	INTEGER, ALLOCATABLE :: ig_paral(:)
[782]	128	INTEGER, DIMENSION(2) :: il_var_nodims
	129	INTEGER, DIMENSION(4) :: il_var_actual_shape
	130	INTEGER :: il_var_type
	131	INTEGER :: jf
	132	CHARACTER (len = 6) :: clmodnam
	133	CHARACTER (len = 20) :: modname = 'inicma'
	134	CHARACTER (len = 80) :: abort_message
[1997]	135	LOGICAL, SAVE :: cpl_current_omp
[782]	136
	137	!* 1. Initializations
	138	! ---------------
	139	!************************************************************************************
[1279]	140	WRITE(lunout,*) ' '
	141	WRITE(lunout,*) ' '
	142	WRITE(lunout,*) ' ROUTINE INICMA'
	143	WRITE(lunout,) ' *************'
	144	WRITE(lunout,*) ' '
	145	WRITE(lunout,*) ' '
[782]	146
	147	!
	148	! Define the model name
	149	!
[3605]	150	IF (grid_type==unstructured) THEN
	151	clmodnam = 'icosa' ! as in $NBMODEL in Cpl/Nam/namcouple.tmp
	152	ELSE IF (grid_type==regular_lonlat) THEN
	153	clmodnam = 'LMDZ' ! as in $NBMODEL in Cpl/Nam/namcouple.tmp
	154	ELSE
	155	abort_message='Pb : type of grid unknown'
	156	CALL abort_physic(modname,abort_message,1)
	157	ENDIF
[1067]	158
[1279]	159
[782]	160	!************************************************************************************
[1067]	161	! Define if coupling ocean currents or not
	162	!************************************************************************************
	163	!$OMP MASTER
	164	cpl_current_omp = .FALSE.
	165	CALL getin('cpl_current', cpl_current_omp)
	166	!$OMP END MASTER
	167	!$OMP BARRIER
	168	cpl_current = cpl_current_omp
[1279]	169	WRITE(lunout,*) 'Couple ocean currents, cpl_current = ',cpl_current
[1067]	170
	171	!************************************************************************************
[1279]	172	! Define coupling variables
	173	!************************************************************************************
	174
	175	! Atmospheric variables to send
	176
	177	!$OMP MASTER
	178	infosend(:)%action = .FALSE.
	179
	180	infosend(ids_tauxxu)%action = .TRUE. ; infosend(ids_tauxxu)%name = 'COTAUXXU'
	181	infosend(ids_tauyyu)%action = .TRUE. ; infosend(ids_tauyyu)%name = 'COTAUYYU'
	182	infosend(ids_tauzzu)%action = .TRUE. ; infosend(ids_tauzzu)%name = 'COTAUZZU'
	183	infosend(ids_tauxxv)%action = .TRUE. ; infosend(ids_tauxxv)%name = 'COTAUXXV'
	184	infosend(ids_tauyyv)%action = .TRUE. ; infosend(ids_tauyyv)%name = 'COTAUYYV'
	185	infosend(ids_tauzzv)%action = .TRUE. ; infosend(ids_tauzzv)%name = 'COTAUZZV'
	186	infosend(ids_windsp)%action = .TRUE. ; infosend(ids_windsp)%name = 'COWINDSP'
	187	infosend(ids_shfice)%action = .TRUE. ; infosend(ids_shfice)%name = 'COSHFICE'
	188	infosend(ids_nsfice)%action = .TRUE. ; infosend(ids_nsfice)%name = 'CONSFICE'
	189	infosend(ids_dflxdt)%action = .TRUE. ; infosend(ids_dflxdt)%name = 'CODFLXDT'
	190	infosend(ids_calvin)%action = .TRUE. ; infosend(ids_calvin)%name = 'COCALVIN'
	191
[3627]	192	if (activate_ocean_skin == 2) then
	193	infosend(ids_t_int)%action = .TRUE.
	194	infosend(ids_t_int)%name = 'T_int'
[3628]	195	infosend(ids_s_int)%action = .TRUE.
	196	infosend(ids_s_int)%name = 'S_int'
[3627]	197	end if
	198
[1279]	199	IF (version_ocean=='nemo') THEN
	200	infosend(ids_shftot)%action = .TRUE. ; infosend(ids_shftot)%name = 'COQSRMIX'
	201	infosend(ids_nsftot)%action = .TRUE. ; infosend(ids_nsftot)%name = 'COQNSMIX'
	202	infosend(ids_totrai)%action = .TRUE. ; infosend(ids_totrai)%name = 'COTOTRAI'
	203	infosend(ids_totsno)%action = .TRUE. ; infosend(ids_totsno)%name = 'COTOTSNO'
	204	infosend(ids_toteva)%action = .TRUE. ; infosend(ids_toteva)%name = 'COTOTEVA'
	205	infosend(ids_icevap)%action = .TRUE. ; infosend(ids_icevap)%name = 'COICEVAP'
	206	infosend(ids_liqrun)%action = .TRUE. ; infosend(ids_liqrun)%name = 'COLIQRUN'
	207	infosend(ids_taumod)%action = .TRUE. ; infosend(ids_taumod)%name = 'COTAUMOD'
	208	IF (carbon_cycle_cpl) THEN
	209	infosend(ids_atmco2)%action = .TRUE. ; infosend(ids_atmco2)%name = 'COATMCO2'
	210	ENDIF
[2872]	211	infosend(ids_qraioc)%action = .TRUE. ; infosend(ids_qraioc)%name = 'COQRAIOC'
	212	infosend(ids_qsnooc)%action = .TRUE. ; infosend(ids_qsnooc)%name = 'COQSNOOC'
	213	infosend(ids_qraiic)%action = .TRUE. ; infosend(ids_qraiic)%name = 'COQRAIIC'
	214	infosend(ids_qsnoic)%action = .TRUE. ; infosend(ids_qsnoic)%name = 'COQSNOIC'
[1279]	215
	216	ELSE IF (version_ocean=='opa8') THEN
	217	infosend(ids_shfoce)%action = .TRUE. ; infosend(ids_shfoce)%name = 'COSHFOCE'
	218	infosend(ids_nsfoce)%action = .TRUE. ; infosend(ids_nsfoce)%name = 'CONSFOCE'
	219	infosend(ids_icevap)%action = .TRUE. ; infosend(ids_icevap)%name = 'COTFSICE'
	220	infosend(ids_ocevap)%action = .TRUE. ; infosend(ids_ocevap)%name = 'COTFSOCE'
	221	infosend(ids_totrai)%action = .TRUE. ; infosend(ids_totrai)%name = 'COTOLPSU'
	222	infosend(ids_totsno)%action = .TRUE. ; infosend(ids_totsno)%name = 'COTOSPSU'
	223	infosend(ids_runcoa)%action = .TRUE. ; infosend(ids_runcoa)%name = 'CORUNCOA'
	224	infosend(ids_rivflu)%action = .TRUE. ; infosend(ids_rivflu)%name = 'CORIVFLU'
	225	ENDIF
	226
	227	! Oceanic variables to receive
	228
	229	inforecv(:)%action = .FALSE.
	230
	231	inforecv(idr_sisutw)%action = .TRUE. ; inforecv(idr_sisutw)%name = 'SISUTESW'
	232	inforecv(idr_icecov)%action = .TRUE. ; inforecv(idr_icecov)%name = 'SIICECOV'
	233	inforecv(idr_icealw)%action = .TRUE. ; inforecv(idr_icealw)%name = 'SIICEALW'
	234	inforecv(idr_icetem)%action = .TRUE. ; inforecv(idr_icetem)%name = 'SIICTEMW'
[3627]	235
	236	if (activate_ocean_skin >= 1) then
	237	inforecv(idr_sss)%action = .TRUE.
	238	inforecv(idr_sss)%name = 'salinity'
	239	end if
[1279]	240
	241	IF (cpl_current ) THEN
	242	inforecv(idr_curenx)%action = .TRUE. ; inforecv(idr_curenx)%name = 'CURRENTX'
	243	inforecv(idr_cureny)%action = .TRUE. ; inforecv(idr_cureny)%name = 'CURRENTY'
	244	inforecv(idr_curenz)%action = .TRUE. ; inforecv(idr_curenz)%name = 'CURRENTZ'
	245	ENDIF
	246
	247	IF (carbon_cycle_cpl ) THEN
	248	inforecv(idr_oceco2)%action = .TRUE. ; inforecv(idr_oceco2)%name = 'SICO2FLX'
	249	ENDIF
	250
	251	!************************************************************************************
[782]	252	! Here we go: psmile initialisation
	253	!************************************************************************************
	254	IF (is_sequential) THEN
	255	CALL prism_init_comp_proto (comp_id, clmodnam, ierror)
	256
	257	IF (ierror .NE. PRISM_Ok) THEN
	258	abort_message=' Probleme init dans prism_init_comp '
[2311]	259	CALL abort_physic(modname,abort_message,1)
[782]	260	ELSE
[1279]	261	WRITE(lunout,*) 'inicma : init psmile ok '
[782]	262	ENDIF
	263	ENDIF
	264
	265	CALL prism_get_localcomm_proto (il_commlocal, ierror)
	266	!************************************************************************************
	267	! Domain decomposition
	268	!************************************************************************************
[3605]	269	IF (grid_type==unstructured) THEN
[782]	270
[3605]	271	ALLOCATE( ig_paral(klon_mpi_para_nb(mpi_rank) + 2) )
	272
	273	ig_paral(1) = 4 ! points partition for //
	274	ig_paral(2) = klon_mpi_para_nb(mpi_rank) ! nb of local cells
	275
	276	DO jf=1, klon_mpi_para_nb(mpi_rank)
	277	ig_paral(2+jf) = ind_cell_glo(jf)
	278	ENDDO
	279
	280	ELSE IF (grid_type==regular_lonlat) THEN
	281
	282	ALLOCATE( ig_paral(3) )
	283
	284	ig_paral(1) = 1 ! apple partition for //
	285	ig_paral(2) = (jj_begin-1)*nbp_lon+ii_begin-1 ! offset
	286	ig_paral(3) = (jj_endnbp_lon+ii_end) - (jj_beginnbp_lon+ii_begin) + 1
	287
	288	IF (mpi_rank==mpi_size-1) ig_paral(3)=ig_paral(3)+nbp_lon-1
	289	ELSE
	290	abort_message='Pb : type of grid unknown'
	291	CALL abort_physic(modname,abort_message,1)
	292	ENDIF
	293
	294
[1279]	295	WRITE(lunout,*) mpi_rank,'ig_paral--->',ig_paral(2),ig_paral(3)
[782]	296
	297	ierror=PRISM_Ok
	298	CALL prism_def_partition_proto (il_part_id, ig_paral, ierror)
	299
	300	IF (ierror .NE. PRISM_Ok) THEN
	301	abort_message=' Probleme dans prism_def_partition '
[2311]	302	CALL abort_physic(modname,abort_message,1)
[782]	303	ELSE
[1279]	304	WRITE(lunout,*) 'inicma : decomposition domaine psmile ok '
[782]	305	ENDIF
	306
[3605]	307	il_var_nodims(1) = 2 ! rank of field array (1d or 2d)
	308	il_var_nodims(2) = 1 ! always 1 in current oasis version" doc oasis3mct p18
[782]	309
[3605]	310	il_var_actual_shape(1) = 1 ! min of 1st dimension (always 1)
	311	il_var_actual_shape(2) = nbp_lon ! max of 1st dimension
	312	il_var_actual_shape(3) = 1 ! min of 2nd dimension (always 1)
	313	il_var_actual_shape(4) = nbp_lat ! max of 2nd dimension
[782]	314
	315	il_var_type = PRISM_Real
	316
	317	!************************************************************************************
[1279]	318	! Oceanic Fields to receive
	319	! Loop over all possible variables
[782]	320	!************************************************************************************
[1279]	321	DO jf=1, maxrecv
	322	IF (inforecv(jf)%action) THEN
	323	CALL prism_def_var_proto(inforecv(jf)%nid, inforecv(jf)%name, il_part_id, &
	324	il_var_nodims, PRISM_In, il_var_actual_shape, il_var_type, &
	325	ierror)
	326	IF (ierror .NE. PRISM_Ok) THEN
	327	WRITE(lunout,*) 'inicma : Problem with prism_def_var_proto for field : ',&
	328	inforecv(jf)%name
	329	abort_message=' Problem in call to prism_def_var_proto for fields to receive'
[2311]	330	CALL abort_physic(modname,abort_message,1)
[1279]	331	ENDIF
[782]	332	ENDIF
	333	END DO
[1279]	334
[782]	335	!************************************************************************************
[1279]	336	! Atmospheric Fields to send
	337	! Loop over all possible variables
[782]	338	!************************************************************************************
[1279]	339	DO jf=1,maxsend
	340	IF (infosend(jf)%action) THEN
	341	CALL prism_def_var_proto(infosend(jf)%nid, infosend(jf)%name, il_part_id, &
	342	il_var_nodims, PRISM_Out, il_var_actual_shape, il_var_type, &
	343	ierror)
	344	IF (ierror .NE. PRISM_Ok) THEN
	345	WRITE(lunout,*) 'inicma : Problem with prism_def_var_proto for field : ',&
	346	infosend(jf)%name
	347	abort_message=' Problem in call to prism_def_var_proto for fields to send'
[2311]	348	CALL abort_physic(modname,abort_message,1)
[1279]	349	ENDIF
[782]	350	ENDIF
	351	END DO
[1279]	352
[782]	353	!************************************************************************************
	354	! End definition
	355	!************************************************************************************
[3605]	356	#ifdef CPP_XIOS
	357	CALL xios_oasis_enddef()
	358	#endif
[782]	359	CALL prism_enddef_proto(ierror)
	360	IF (ierror .NE. PRISM_Ok) THEN
[1279]	361	abort_message=' Problem in call to prism_endef_proto'
[2311]	362	CALL abort_physic(modname,abort_message,1)
[782]	363	ELSE
[1279]	364	WRITE(lunout,*) 'inicma : endef psmile ok '
[782]	365	ENDIF
[1279]	366
[2054]	367	#ifdef CPP_XIOS
[3605]	368	! CALL wxios_context_init()
[2054]	369	#endif
	370
[1279]	371	!$OMP END MASTER
[782]	372
	373	END SUBROUTINE inicma
	374
	375	!
	376	!************************************************************************************
	377	!
	378
	379	SUBROUTINE fromcpl(ktime, tab_get)
	380	! ======================================================================
	381	! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine reads the SST
	382	! and Sea-Ice provided by the coupler. Adaptation to psmile library
	383	!======================================================================
	384	!
[2311]	385	USE print_control_mod, ONLY: lunout
[2371]	386	USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat
[782]	387	! Input arguments
	388	!************************************************************************************
	389	INTEGER, INTENT(IN) :: ktime
	390
	391	! Output arguments
	392	!************************************************************************************
[2346]	393	REAL, DIMENSION(nbp_lon, jj_nb,maxrecv), INTENT(OUT) :: tab_get
[782]	394
	395	! Local variables
	396	!************************************************************************************
	397	INTEGER :: ierror, i
	398	INTEGER :: istart,iend
	399	CHARACTER (len = 20) :: modname = 'fromcpl'
	400	CHARACTER (len = 80) :: abort_message
[2346]	401	REAL, DIMENSION(nbp_lon*jj_nb) :: field
[782]	402
	403	!************************************************************************************
[1279]	404	WRITE (lunout,*) ' '
	405	WRITE (lunout,*) 'Fromcpl: Reading fields from CPL, ktime=',ktime
	406	WRITE (lunout,*) ' '
[782]	407
	408	istart=ii_begin
[2429]	409	IF (is_south_pole_dyn) THEN
[2346]	410	iend=(jj_end-jj_begin)*nbp_lon+nbp_lon
[782]	411	ELSE
[2346]	412	iend=(jj_end-jj_begin)*nbp_lon+ii_end
[782]	413	ENDIF
	414
[1279]	415	DO i = 1, maxrecv
[1965]	416	IF (inforecv(i)%action .AND. inforecv(i)%nid .NE. -1) THEN
[1279]	417	field(:) = -99999.
	418	CALL prism_get_proto(inforecv(i)%nid, ktime, field(istart:iend), ierror)
[2346]	419	tab_get(:,:,i) = RESHAPE(field(:),(/nbp_lon,jj_nb/))
[782]	420
[1279]	421	IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Recvd .AND. &
	422	ierror.NE.PRISM_FromRest &
	423	.AND. ierror.NE.PRISM_Input .AND. ierror.NE.PRISM_RecvOut &
	424	.AND. ierror.NE.PRISM_FromRestOut) THEN
	425	WRITE (lunout,*) 'Error with receiving filed : ', inforecv(i)%name, ktime
	426	abort_message=' Problem in prism_get_proto '
[2311]	427	CALL abort_physic(modname,abort_message,1)
[1279]	428	ENDIF
	429	ENDIF
[782]	430	END DO
	431
	432
	433	END SUBROUTINE fromcpl
	434
	435	!
	436	!************************************************************************************
	437	!
	438
	439	SUBROUTINE intocpl(ktime, last, tab_put)
	440	! ======================================================================
	441	! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine provides the
	442	! atmospheric coupling fields to the coupler with the psmile library.
	443	! IF last time step, writes output fields to binary files.
	444	! ======================================================================
	445	!
	446	!
[2311]	447	USE print_control_mod, ONLY: lunout
[2371]	448	USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat
[782]	449	! Input arguments
	450	!************************************************************************************
[1279]	451	INTEGER, INTENT(IN) :: ktime
	452	LOGICAL, INTENT(IN) :: last
[2346]	453	REAL, DIMENSION(nbp_lon, jj_nb, maxsend), INTENT(IN) :: tab_put
[782]	454
	455	! Local variables
	456	!************************************************************************************
[987]	457	LOGICAL :: checkout
	458	INTEGER :: istart,iend
	459	INTEGER :: wstart,wend
	460	INTEGER :: ierror, i
[2346]	461	REAL, DIMENSION(nbp_lon*jj_nb) :: field
[987]	462	CHARACTER (len = 20),PARAMETER :: modname = 'intocpl'
	463	CHARACTER (len = 80) :: abort_message
[782]	464
	465	!************************************************************************************
[987]	466	checkout=.FALSE.
[782]	467
[1279]	468	WRITE(lunout,*) ' '
	469	WRITE(lunout,*) 'Intocpl: sending fields to CPL, ktime= ', ktime
	470	WRITE(lunout,*) 'last = ', last
	471	WRITE(lunout,*)
[782]	472
	473
	474	istart=ii_begin
[2429]	475	IF (is_south_pole_dyn) THEN
[2346]	476	iend=(jj_end-jj_begin)*nbp_lon+nbp_lon
[782]	477	ELSE
[2346]	478	iend=(jj_end-jj_begin)*nbp_lon+ii_end
[782]	479	ENDIF
	480
	481	IF (checkout) THEN
	482	wstart=istart
	483	wend=iend
[2429]	484	IF (is_north_pole_dyn) wstart=istart+nbp_lon-1
	485	IF (is_south_pole_dyn) wend=iend-nbp_lon+1
[782]	486
[1279]	487	DO i = 1, maxsend
	488	IF (infosend(i)%action) THEN
[2346]	489	field = RESHAPE(tab_put(:,:,i),(/nbp_lon*jj_nb/))
[1279]	490	CALL writefield_phy(infosend(i)%name,field(wstart:wend),1)
	491	END IF
	492	END DO
	493	END IF
	494
[782]	495	!************************************************************************************
	496	! PRISM_PUT
	497	!************************************************************************************
	498
[1279]	499	DO i = 1, maxsend
[1965]	500	IF (infosend(i)%action .AND. infosend(i)%nid .NE. -1 ) THEN
[2346]	501	field = RESHAPE(tab_put(:,:,i),(/nbp_lon*jj_nb/))
[1279]	502	CALL prism_put_proto(infosend(i)%nid, ktime, field(istart:iend), ierror)
	503
	504	IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Sent .AND. ierror.NE.PRISM_ToRest &
	505	.AND. ierror.NE.PRISM_LocTrans .AND. ierror.NE.PRISM_Output .AND. &
	506	ierror.NE.PRISM_SentOut .AND. ierror.NE.PRISM_ToRestOut) THEN
	507	WRITE (lunout,*) 'Error with sending field :', infosend(i)%name, ktime
	508	abort_message=' Problem in prism_put_proto '
[2311]	509	CALL abort_physic(modname,abort_message,1)
[1279]	510	ENDIF
	511	ENDIF
[782]	512	END DO
	513
	514	!************************************************************************************
	515	! Finalize PSMILE for the case is_sequential, if parallel finalization is done
	516	! from Finalize_parallel in dyn3dpar/parallel.F90
	517	!************************************************************************************
	518
	519	IF (last) THEN
	520	IF (is_sequential) THEN
	521	CALL prism_terminate_proto(ierror)
	522	IF (ierror .NE. PRISM_Ok) THEN
[1279]	523	abort_message=' Problem in prism_terminate_proto '
[2311]	524	CALL abort_physic(modname,abort_message,1)
[782]	525	ENDIF
	526	ENDIF
	527	ENDIF
	528
	529
	530	END SUBROUTINE intocpl
	531
	532	#endif
	533
	534	END MODULE oasis

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format