Context Navigation

oasis.F90 @ 5844

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

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

Download in other formats:

Original Format