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

Last change on this file since 2715 was 2715, checked in by rblod, 10 years ago

First attempt to put dynamic allocation on the trunk

  • Property svn:keywords set to Id
File size: 13.1 KB
Line 
1MODULE flowri
2   !!======================================================================
3   !!                       ***  MODULE  flowri  ***
4   !! lagrangian floats :   outputs
5   !!======================================================================
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   !!----------------------------------------------------------------------
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
25   PUBLIC   flo_wri         ! routine called by floats.F90
26   PUBLIC   flo_wri_alloc   ! routine called by floats.F90
27
28   INTEGER ::   jfl      ! number of floats
29   INTEGER ::   numflo   ! logical unit for drifting floats
30
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
36   !! * Substitutions
37#  include "domzgr_substitute.h90"
38   !!----------------------------------------------------------------------
39   !! NEMO/OPA 4.0 , NEMO Consortium (2011)
40   !! $Id$
41   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
42   !!----------------------------------------------------------------------
43CONTAINS
44
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
56   SUBROUTINE flo_wri( kt )
57      !!-------------------------------------------------------------------
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      !!     
63      !! ** Method  :   The frequency is nn_writefl
64      !!----------------------------------------------------------------------
65      INTEGER ::   kt   ! time step
66      !!
67      CHARACTER (len=21) ::  clname
68      INTEGER ::   inum   ! temporary logical unit for restart file
69      INTEGER ::   iafl, ibfl, icfl, ia1fl, ib1fl, ic1fl, jfl, irecflo
70      INTEGER ::   iafloc, ibfloc, ia1floc, ib1floc, iafln, ibfln
71      INTEGER  ::    ic, jc , jpn
72      INTEGER, DIMENSION ( jpnij )  ::   iproc
73      REAL(wp) ::   zafl, zbfl, zcfl, zdtj
74      REAL(wp) ::   zxxu, zxxu_01,zxxu_10, zxxu_11
75      !!---------------------------------------------------------------------
76     
77      IF( kt == nit000 .OR. MOD( kt,nn_writefl) == 0 ) THEN 
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
88         CALL ctl_opn( numflo, 'trajec_float', 'REPLACE', 'UNFORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. )
89
90         IF( kt == nit000 ) THEN
91            irecflo = NINT( (nitend-nit000) / FLOAT(nn_writefl) )
92            IF(lwp) WRITE(numflo)cexper,no,irecflo,jpnfl,nn_writefl
93         ENDIF
94         zdtj = rdt / 86400._wp
95
96         ! translation of index position in geographical position
97
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
113
114                  ! local index
115
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
147!bug RB
148!compilation failed in mpp
149!            CALL mpp_sum( ztemp, jpk*jpnfl )
150!            CALL mpp_sum( zsal , jpk*jpnfl )
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
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)
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)
181
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         
187               ! Change  by Alexandra Bozec et Jean-Philippe Boulanger
188               ! We save  the instantaneous profile of T and S of the column     
189               !     ztemp(jfl)=tn(iafloc,ibfloc,icfl)
190               !     zsal(jfl)=sn(iafloc,ibfloc,icfl)
191               ztemp(1:jpk,jfl) = tn(iafloc,ibfloc,1:jpk)
192               zsal (1:jpk,jfl) = sn(iafloc,ibfloc,1:jpk)
193            END DO
194         ENDIF
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))
209      !# if defined key_mpp_mpi   
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)
228      !# if defined key_mpp_mpi   
229      !        ELSE
230      !         ztemp(jfl) = 0.
231      !         zsal(jfl) = 0.
232      !        ENDIF
233      !# endif
234      !! ... next float
235      !        END DO
236      !      IF( lk_mpp )   CALL mpp_sum( ztemp, jpnfl )
237      !      IF( lk_mpp )   CALL mpp_sum( zsal , jpnfl )
238      !
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     
253      IF( (MOD(kt,nn_stockfl) == 0) .OR. ( kt == nitend ) ) THEN 
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
274         CALL ctl_opn( inum, clname, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. )
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         !
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
296               ENDIF
297            END DO
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
308         ENDIF
309      ENDIF
310
311      IF( kt == nitend )   CLOSE( numflo ) 
312      !
313   END SUBROUTINE flo_wri
314
315#  else
316   !!----------------------------------------------------------------------
317   !!   Default option                                         Empty module
318   !!----------------------------------------------------------------------
319CONTAINS
320   SUBROUTINE flo_wri                 ! Empty routine
321   END SUBROUTINE flo_wri
322#endif
323   
324   !!======================================================================
325END MODULE flowri
Note: See TracBrowser for help on using the repository browser.