New URL for NEMO forge! http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.

flowri.F90 in trunk/NEMOGCM/NEMO/OPA_SRC/FLO – NEMO

Context Navigation

source: trunk/NEMOGCM/NEMO/OPA_SRC/FLO/flowri.F90 @ 2715

Last change on this file since 2715 was 2715, checked in by rblod, 13 years ago
First attempt to put dynamic allocation on the trunk
Property svn:keywords set to `Id`
File size: 13.1 KB

Rev	Line
[3]	1	MODULE flowri
	2	!!======================================================================
	3	!! * MODULE flowri *
[1601]	4	!! lagrangian floats : outputs
[3]	5	!!======================================================================
[1601]	6	!! History : OPA ! 1999-09 (Y. Drillet) Original code
	7	!! ! 2000-06 (J.-M. Molines) Profiling floats for CLS
	8	!! NEMO 1.0 ! 2002-11 (G. Madec, A. Bozec) F90: Free form and module
	9	!!----------------------------------------------------------------------
[3]	10	#if defined key_floats \|\| defined key_esopa
	11	!!----------------------------------------------------------------------
	12	!! 'key_floats' float trajectories
	13	!!----------------------------------------------------------------------
	14	!! flowri : write trajectories of floats in file
	15	!!----------------------------------------------------------------------
	16	USE flo_oce ! ocean drifting floats
	17	USE oce ! ocean dynamics and tracers
	18	USE dom_oce ! ocean space and time domain
	19	USE lib_mpp ! distribued memory computing library
	20	USE in_out_manager ! I/O manager
	21
	22	IMPLICIT NONE
	23	PRIVATE
	24
[2715]	25	PUBLIC flo_wri ! routine called by floats.F90
	26	PUBLIC flo_wri_alloc ! routine called by floats.F90
[3]	27
[1685]	28	INTEGER :: jfl ! number of floats
	29	INTEGER :: numflo ! logical unit for drifting floats
[1601]	30
[2715]	31	! Following are only workspace arrays but shape is not (jpi,jpj) and
	32	! therefore make them module arrays rather than replacing with wrk_nemo
	33	! member arrays.
	34	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ztemp, zsal ! 2D workspace
	35
[3]	36	!! * Substitutions
	37	# include "domzgr_substitute.h90"
	38	!!----------------------------------------------------------------------
[2715]	39	!! NEMO/OPA 4.0 , NEMO Consortium (2011)
[1152]	40	!! $Id$
[2528]	41	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
[3]	42	!!----------------------------------------------------------------------
	43	CONTAINS
	44
[2715]	45	INTEGER FUNCTION flo_wri_alloc
	46	!!-------------------------------------------------------------------
	47	!! * FUNCTION flo_wri_alloc *
	48	!!-------------------------------------------------------------------
	49	ALLOCATE( ztemp(jpk,jpnfl) , zsal(jpk,jpnfl) , STAT=flo_wri_alloc)
	50	!
	51	IF( lk_mpp ) CALL mpp_sum ( flo_wri_alloc )
	52	IF( flo_wri_alloc /= 0 ) CALL ctl_warn('flo_wri_alloc: failed to allocate arrays.')
	53	END FUNCTION flo_wri_alloc
	54
	55
[3]	56	SUBROUTINE flo_wri( kt )
[1601]	57	!!-------------------------------------------------------------------
[3]	58	!! * ROUTINE flo_wri *
	59	!!
	60	!! ** Purpose : Write position of floats in "trajec_float" file
	61	!! and the temperature and salinity at this position
	62	!!
[1601]	63	!! ** Method : The frequency is nn_writefl
[3]	64	!!----------------------------------------------------------------------
[1601]	65	INTEGER :: kt ! time step
	66	!!
[16]	67	CHARACTER (len=21) :: clname
[1601]	68	INTEGER :: inum ! temporary logical unit for restart file
[2528]	69	INTEGER :: iafl, ibfl, icfl, ia1fl, ib1fl, ic1fl, jfl, irecflo
[1601]	70	INTEGER :: iafloc, ibfloc, ia1floc, ib1floc, iafln, ibfln
[3]	71	INTEGER :: ic, jc , jpn
[2528]	72	INTEGER, DIMENSION ( jpnij ) :: iproc
[2715]	73	REAL(wp) :: zafl, zbfl, zcfl, zdtj
[2528]	74	REAL(wp) :: zxxu, zxxu_01,zxxu_10, zxxu_11
[3]	75	!!---------------------------------------------------------------------
	76
[2715]	77	IF( kt == nit000 .OR. MOD( kt,nn_writefl) == 0 ) THEN
[3]	78
	79	! header of output floats file
	80
	81	IF(lwp) THEN
	82	WRITE(numout,*)
	83	WRITE(numout,*) 'flo_wri : write in trajec_float file '
	84	WRITE(numout,*) '~~~~~~~ '
	85	ENDIF
	86
	87	! open the file numflo
[1581]	88	CALL ctl_opn( numflo, 'trajec_float', 'REPLACE', 'UNFORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. )
[3]	89
	90	IF( kt == nit000 ) THEN
[1601]	91	irecflo = NINT( (nitend-nit000) / FLOAT(nn_writefl) )
	92	IF(lwp) WRITE(numflo)cexper,no,irecflo,jpnfl,nn_writefl
[3]	93	ENDIF
[2528]	94	zdtj = rdt / 86400._wp
[3]	95
	96	! translation of index position in geographical position
	97
[16]	98	IF( lk_mpp ) THEN
	99	DO jfl = 1, jpnfl
	100	iafl = INT ( tpifl(jfl) )
	101	ibfl = INT ( tpjfl(jfl) )
	102	icfl = INT ( tpkfl(jfl) )
	103	iafln = NINT( tpifl(jfl) )
	104	ibfln = NINT( tpjfl(jfl) )
	105	ia1fl = iafl + 1
	106	ib1fl = ibfl + 1
	107	ic1fl = icfl + 1
	108	zafl = tpifl(jfl) - FLOAT( iafl )
	109	zbfl = tpjfl(jfl) - FLOAT( ibfl )
	110	zcfl = tpkfl(jfl) - FLOAT( icfl )
	111	IF( iafl >= mig(nldi)-jpizoom+1 .AND. iafl <= mig(nlei)-jpizoom+1 .AND. &
	112	& ibfl >= mjg(nldj)-jpjzoom+1 .AND. ibfl <= mjg(nlej)-jpjzoom+1 ) THEN
[3]	113
[16]	114	! local index
[3]	115
[16]	116	iafloc = iafl -(mig(1)-jpizoom+1) + 1
	117	ibfloc = ibfl -(mjg(1)-jpjzoom+1) + 1
	118	ia1floc = iafloc + 1
	119	ib1floc = ibfloc + 1
	120
	121	flyy(jfl) = (1.-zafl)(1.-zbfl)gphit(iafloc ,ibfloc ) + (1.-zafl) * zbfl * gphit(iafloc ,ib1floc) &
	122	& + zafl (1.-zbfl)gphit(ia1floc,ibfloc ) + zafl * zbfl * gphit(ia1floc,ib1floc)
	123	flxx(jfl) = (1.-zafl)(1.-zbfl)glamt(iafloc ,ibfloc ) + (1.-zafl) * zbfl * glamt(iafloc ,ib1floc) &
	124	& + zafl (1.-zbfl)glamt(ia1floc,ibfloc ) + zafl * zbfl * glamt(ia1floc,ib1floc)
	125	flzz(jfl) = (1.-zcfl)fsdepw(iafloc,ibfloc,icfl ) + zcfl fsdepw(iafloc,ibfloc,ic1fl)
	126
	127	! Change by Alexandra Bozec et Jean-Philippe Boulanger
	128	! We save the instantaneous profile of T and S of the column
	129	! ztemp(jfl)=tn(iafloc,ibfloc,icfl)
	130	! zsal(jfl)=sn(iafloc,ibfloc,icfl)
	131	ztemp(1:jpk,jfl) = tn(iafloc,ibfloc,1:jpk)
	132	zsal (1:jpk,jfl) = sn(iafloc,ibfloc,1:jpk)
	133	ELSE
	134	flxx(jfl) = 0.
	135	flyy(jfl) = 0.
	136	flzz(jfl) = 0.
	137	ztemp(1:jpk,jfl) = 0.
	138	zsal (1:jpk,jfl) = 0.
	139	ENDIF
	140	END DO
	141
	142	CALL mpp_sum( flxx, jpnfl ) ! sums over the global domain
	143	CALL mpp_sum( flyy, jpnfl )
	144	CALL mpp_sum( flzz, jpnfl )
	145	! these 2 lines have accendentaly been removed from ATL6-V8 run hence
	146	! giving 0 salinity and temperature on the float trajectory
[623]	147	!bug RB
	148	!compilation failed in mpp
	149	! CALL mpp_sum( ztemp, jpk*jpnfl )
	150	! CALL mpp_sum( zsal , jpk*jpnfl )
[16]	151
	152	ELSE
	153	DO jfl = 1, jpnfl
	154	iafl = INT (tpifl(jfl))
	155	ibfl = INT (tpjfl(jfl))
	156	icfl = INT (tpkfl(jfl))
	157	iafln = NINT(tpifl(jfl))
	158	ibfln = NINT(tpjfl(jfl))
	159	ia1fl = iafl+1
	160	ib1fl = ibfl+1
	161	ic1fl = icfl+1
	162	zafl = tpifl(jfl) - FLOAT(iafl)
	163	zbfl = tpjfl(jfl) - FLOAT(ibfl)
	164	zcfl = tpkfl(jfl) - FLOAT(icfl)
	165	iafloc = iafl
	166	ibfloc = ibfl
[3]	167	ia1floc = iafloc + 1
	168	ib1floc = ibfloc + 1
	169	!
	170	flyy(jfl) = (1.-zafl)(1.-zbfl)gphit(iafloc ,ibfloc ) + (1.-zafl) * zbfl * gphit(iafloc ,ib1floc) &
	171	+ zafl (1.-zbfl)gphit(ia1floc,ibfloc ) + zafl * zbfl * gphit(ia1floc,ib1floc)
	172	flxx(jfl) = (1.-zafl)(1.-zbfl)glamt(iafloc ,ibfloc ) + (1.-zafl) * zbfl * glamt(iafloc ,ib1floc) &
	173	+ zafl (1.-zbfl)glamt(ia1floc,ibfloc ) + zafl * zbfl * glamt(ia1floc,ib1floc)
	174	flzz(jfl) = (1.-zcfl)fsdepw(iafloc,ibfloc,icfl ) + zcfl fsdepw(iafloc,ibfloc,ic1fl)
[16]	175	!ALEX
	176	! Astuce pour ne pas avoir des flotteurs qui se baladent sur IDL
	177	zxxu_11 = glamt(iafloc ,ibfloc )
	178	zxxu_10 = glamt(iafloc ,ib1floc)
	179	zxxu_01 = glamt(ia1floc,ibfloc )
	180	zxxu = glamt(ia1floc,ib1floc)
[3]	181
[16]	182	IF( iafloc == 52 ) zxxu_10 = -181
	183	IF( iafloc == 52 ) zxxu_11 = -181
	184	flxx(jfl)=(1.-zafl)(1.-zbfl) zxxu_11 + (1.-zafl)* zbfl * zxxu_10 &
	185	+ zafl (1.-zbfl) zxxu_01 + zafl * zbfl * zxxu
	186	!ALEX
[3]	187	! Change by Alexandra Bozec et Jean-Philippe Boulanger
	188	! We save the instantaneous profile of T and S of the column
[16]	189	! ztemp(jfl)=tn(iafloc,ibfloc,icfl)
	190	! zsal(jfl)=sn(iafloc,ibfloc,icfl)
[3]	191	ztemp(1:jpk,jfl) = tn(iafloc,ibfloc,1:jpk)
[16]	192	zsal (1:jpk,jfl) = sn(iafloc,ibfloc,1:jpk)
	193	END DO
	194	ENDIF
[3]	195
	196	!
	197	WRITE(numflo) flxx,flyy,flzz,nisobfl,ngrpfl,ztemp,zsal, FLOAT(ndastp)
	198	!!
	199	!! case when profiles are dumped. In order to save memory, dumps are
	200	!! done level by level.
	201	! IF (mod(kt,nflclean) == 0.) THEN
	202	!! IF ( nwflo == nwprofil ) THEN
	203	! DO jk = 1,jpk
	204	! DO jfl=1,jpnfl
	205	! iafl= INT(tpifl(jfl))
	206	! ibfl=INT(tpjfl(jfl))
	207	! iafln=NINT(tpifl(jfl))
	208	! ibfln=NINT(tpjfl(jfl))
[2528]	209	!# if defined key_mpp_mpi
[3]	210	! IF ( (iafl >= (mig(nldi)-jpizoom+1)) .AND.
	211	! $ (iafl <= (mig(nlei)-jpizoom+1)) .AND.
	212	! $ (ibfl >= (mjg(nldj)-jpjzoom+1)) .AND.
	213	! $ (ibfl <= (mjg(nlej)-jpjzoom+1)) ) THEN
	214	!!
	215	!! local index
	216	!!
	217	! iafloc=iafln-(mig(1)-jpizoom+1)+1
	218	! ibfloc=ibfln-(mjg(1)-jpjzoom+1)+1
	219	!! IF (jk == 1 ) THEN
	220	!! PRINT *,'<<<>>> ',jfl,narea, iafloc ,ibfloc, iafln, ibfln,adatrj
	221	!! ENDIF
	222	!# else
	223	! iafloc=iafln
	224	! ibfloc=ibfln
	225	!# endif
	226	! ztemp(jfl)=tn(iafloc,ibfloc,jk)
	227	! zsal(jfl)=sn(iaflo!,ibfloc,jk)
[2528]	228	!# if defined key_mpp_mpi
[3]	229	! ELSE
	230	! ztemp(jfl) = 0.
	231	! zsal(jfl) = 0.
	232	! ENDIF
	233	!# endif
	234	!! ... next float
	235	! END DO
[16]	236	! IF( lk_mpp ) CALL mpp_sum( ztemp, jpnfl )
	237	! IF( lk_mpp ) CALL mpp_sum( zsal , jpnfl )
	238	!
[3]	239	! IF (lwp) THEN
	240	! WRITE(numflo) ztemp, zsal
	241	! ENDIF
	242	!! ... next level jk
	243	! END DO
	244	!! ... reset nwflo to 0 for ALL processors, if profile has been written
	245	!! nwflo = 0
	246	! ENDIF
	247	!!
	248	! CALL flush (numflo)
	249	!! ... time of dumping floats
	250	!! END IF
	251	ENDIF
	252
[1601]	253	IF( (MOD(kt,nn_stockfl) == 0) .OR. ( kt == nitend ) ) THEN
[3]	254	! Writing the restart file
	255	IF(lwp) THEN
	256	WRITE(numout,*)
	257	WRITE(numout,*) 'flo_wri : write in restart_float file '
	258	WRITE(numout,*) '~~~~~~~ '
	259	ENDIF
	260
	261	! file is opened and closed every time it is used.
	262
	263	clname = 'restart.float.'
	264	ic = 1
	265	DO jc = 1, 16
	266	IF( cexper(jc:jc) /= ' ' ) ic = jc
	267	END DO
	268	clname = clname(1:14)//cexper(1:ic)
	269	ic = 1
	270	DO jc = 1, 48
	271	IF( clname(jc:jc) /= ' ' ) ic = jc
	272	END DO
	273
[1581]	274	CALL ctl_opn( inum, clname, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. )
[3]	275	REWIND inum
	276	!
	277	DO jpn = 1, jpnij
	278	iproc(jpn) = 0
	279	END DO
	280	!
	281	IF(lwp) THEN
	282	REWIND(inum)
	283	WRITE (inum) tpifl,tpjfl,tpkfl,nisobfl,ngrpfl
	284	CLOSE (inum)
	285	ENDIF
	286	!
	287	! Compute the number of trajectories for each processor
	288	!
[16]	289	IF( lk_mpp ) THEN
	290	DO jfl = 1, jpnfl
	291	IF( (INT(tpifl(jfl)) >= (mig(nldi)-jpizoom+1)) .AND. &
	292	&(INT(tpifl(jfl)) <= (mig(nlei)-jpizoom+1)) .AND. &
	293	&(INT(tpjfl(jfl)) >= (mjg(nldj)-jpjzoom+1)) .AND. &
	294	&(INT(tpjfl(jfl)) <= (mjg(nlej)-jpjzoom+1)) ) THEN
	295	iproc(narea) = iproc(narea)+1
[3]	296	ENDIF
	297	END DO
[16]	298	CALL mpp_sum( iproc, jpnij )
	299	!
	300	IF(lwp) THEN
	301	WRITE(numout,*) 'DATE',adatrj
	302	DO jpn = 1, jpnij
	303	IF( iproc(jpn) /= 0 ) THEN
	304	WRITE(numout,*)'PROCESSOR',jpn-1,'compute',iproc(jpn), 'trajectories.'
	305	ENDIF
	306	END DO
	307	ENDIF
[3]	308	ENDIF
	309	ENDIF
	310
[1685]	311	IF( kt == nitend ) CLOSE( numflo )
[2528]	312	!
[3]	313	END SUBROUTINE flo_wri
	314
	315	# else
	316	!!----------------------------------------------------------------------
	317	!! Default option Empty module
	318	!!----------------------------------------------------------------------
	319	CONTAINS
	320	SUBROUTINE flo_wri ! Empty routine
	321	END SUBROUTINE flo_wri
	322	#endif
	323
	324	!!======================================================================
	325	END MODULE flowri

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

Download in other formats: