Context Navigation

oasis.F90 @ 5319

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

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

Download in other formats:

Original Format