Context Navigation

oasis.F90 @ 3634

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

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

Download in other formats:

Original Format