File: C:\NOAA\NEMS_11731\src\atmos\gfs\dyn\wrtout_dynamics.f

1           module gfs_dyn_mod_state
2     !
3     c new module to supply domain information
4     c to the GFS output routines called by
5     c wrtout.
6     !
7     ! May 2009 Jun Wang, modified to use write grid component
8     !
9           use gfs_dyn_machine
10           use gfs_dyn_resol_def
11           implicit none
12     !
13           real(kind=kind_io4), allocatable,target :: buff_mult_pieceg(:,:,:)
14           real(kind=kind_io4), allocatable :: buff_mult_piecesg(:)
15     !
16           real(kind=kind_io4), allocatable :: buff_mult_piece(:,:,:),
17          1                                    buff_mult_pieces(:,:,:,:)
18           real(kind=kind_io4), allocatable :: buff_mult_piecef(:,:,:),
19          1                                    buff_mult_piecesf(:,:,:,:)
20           real(kind=kind_io4), allocatable :: buff_mult_piecea(:,:,:),
21          1                                    buff_mult_piecesa(:,:,:,:)
22           integer , allocatable :: ivar_global(:),ivar_global_a(:,:)
23          &,                        ivarg_global(:),ivarg_global_a(:,:)
24     !
25           integer ngrid ,ngrida,ngridg
26           save ngrid,ngrida,buff_mult_piece,buff_mult_pieces,ivar_global
27          &,    ngridg,buff_mult_pieceg,buff_mult_piecesg,ivarg_global
28           end module gfs_dyn_mod_state
29     
30           subroutine wrtout_dynamics(phour,fhour,zhour,idate,
31          &                  TRIE_LS,TRIO_LS,grid_gr,
32          &                  sl,si,
33          &    ls_node,ls_nodes,max_ls_nodes,
34          &    lats_nodes_a,global_lats_a,lonsperlat,nblck,
35          &    colat1,cfhour1,
36          &    epsedn,epsodn,snnp1ev,snnp1od,plnev_a,plnod_a,
37          &    pdryini)
38     !!
39     !! write out only grid values for nemsio
40     !!
41           use gfs_dyn_resol_def
42           use gfs_dyn_layout1
43           use gfs_dyn_coordinate_def
44           use namelist_dynamics_def
45           use gfs_dyn_mpi_def
46           use gfs_dyn_gg_def
47     !     use sigio_module
48     !     use sigio_r_module
49           use gfs_dyn_tracer_const
50           use gfs_dyn_physcons, cp => con_cp 
51          &                    , rd => con_rd, fv => con_fvirt
52          &                    , rkappa => con_rocp
53           implicit none
54     cc
55           CHARACTER(16) :: CFHOUR1         ! for the ESMF Export State Creation
56           integer ixgr
57           real(kind=kind_evod) phour,fhour,zhour
58     cc
59           integer              idate(4),nblck,km,iostat,no3d,ks
60           logical lfnhr
61           real colat1, lat, lan
62           real(kind=8) t1,t2,t3,t4,t5,ta,tb,tc,td,te,tf,rtc,tx,ty
63           real timesum
64     cc
65           real(kind=kind_evod) sl(levs), si(levp1)
66     cc
67           integer              ls_node(ls_dim,3)
68           integer              ls_nodes(ls_dim,nodes)
69           integer              max_ls_nodes(nodes)
70           integer              lats_nodes_a(nodes)
71     
72           real(kind=kind_evod)   tfac(lonf,levs), sumq(lonf,levs)
73           real(kind=kind_evod)   tki(lonf,levs+1)
74           real(kind=kind_evod)   tkrt0, tx2(levs), tem
75           real(kind=kind_evod), parameter :: one=1.0, cb2pa=1000.0
76           real(kind=kind_evod), parameter :: qmin=1.e-10
77           real(kind=kind_evod)  tx1
78           integer               lons_lat,nn,kk,nnl
79     cc
80           integer               ierr,i,j,k,l,lenrec,locl,n,node
81           integer               nosig,nfill,jlonf
82           character*16 cosfc
83           data timesum/0./
84     cc
85           REAL(KIND=KIND_EVOD) TRIE_LS(LEN_TRIE_LS,2,lotls)
86          &,                    TRIO_LS(LEN_TRIO_LS,2,lotls)
87           REAL(KIND=KIND_grid) grid_gr(lonf*lats_node_a_max,lotgr)
88     !!
89           character CFHOUR*40,CFORM*40
90           integer jdate(4),nzsig,ndigyr,ndig,kh,ioproc
91     !!
92           REAL (KIND=KIND_grid) pdryini
93           INTEGER              GLOBAL_lats_a(latg),   lonsperlat(latg)
94     !
95           real(kind=kind_evod)  epsedn(len_trie_ls)
96           real(kind=kind_evod)  epsodn(len_trio_ls)
97     !!
98           real(kind=kind_evod) snnp1ev(len_trie_ls)
99           real(kind=kind_evod) snnp1od(len_trio_ls)
100     !!
101           real(kind=kind_evod)   plnev_a(len_trie_ls,latg2)
102           real(kind=kind_evod)   plnod_a(len_trio_ls,latg2)
103     !!
104           real(kind=kind_grid) zsg(lonf,lats_node_a)
105           real(kind=kind_grid) psg(lonf,lats_node_a)
106           real(kind=kind_grid) dpg(lonf,lats_node_a,levs)
107           real(kind=kind_grid) ttg(lonf,lats_node_a,levs)
108           real(kind=kind_grid) uug(lonf,lats_node_a,levs)
109           real(kind=kind_grid) vvg(lonf,lats_node_a,levs)
110           real(kind=kind_grid) rqg(lonf,lats_node_a,levh)
111     !!
112           real(kind=kind_mpi),allocatable :: trieo_ls_nodes_buf(:,:,:,:,:)
113           real(kind=kind_mpi),allocatable :: trieo_ls_node(:,:,:)
114           save trieo_ls_nodes_buf,trieo_ls_node
115           real(kind=8) tba,tbb,tbc,tbd
116           integer iret
117     !
118           t3=rtc()
119     !jw      call mpi_barrier(mpi_comm_all,ierr)
120           call mpi_barrier(mc_comp,ierr)
121           t4=rtc()
122           tba=t4-t3
123     !jw      if(nodes_comp .lt. 1 .or. nodes_comp .gt. nodes) then
124     !jw        print *, '  NODES_COMP UNDEFINED, CANNOT DO I.O '
125     !jw        call mpi_finalize()
126     !jw         stop 333
127     !jw      endif
128     !
129           ioproc=nodes_comp-1
130           if(allocated ( trieo_ls_node)) then
131             continue
132           else
133             allocate ( trieo_ls_node  ( len_trie_ls_max+len_trio_ls_max,
134          x                            2, 3*levs+1*levh+1 ) )
135           endif
136           t3=rtc()
137     !jw      call shapeset (ls_nodes,max_ls_nodes,pdryini)
138     !jw      call MPI_BARRIER(mpi_comm_all,ierr)
139     !jw      call MPI_BARRIER(mpi_comp,ierr)
140           t4=rtc()
141           tbb=t4-t3
142            
143           if ( allocated (trieo_ls_nodes_buf) )then
144             continue
145           else
146             allocate( trieo_ls_nodes_buf ( len_trie_ls_max+len_trio_ls_max,
147          x                               2, 3*levs+1*levh+1, nodes,1 ) )
148           endif
149           t1=rtc()
150     
151     cc
152     
153     !!
154           JDATE=IDATE
155           ndigyr=4
156           IF(NDIGYR.EQ.2) THEN
157             JDATE(4)=MOD(IDATE(4)-1,100)+1
158           ENDIF
159     
160     csela set lfnhr to false for writing one step output etc.
161           lfnhr=.true.    ! no output
162     !      lfnhr=3600*abs(fhour-nint(fhour)).le.1.or.phour.eq.0
163           lfnhr=3600*abs(fhour-nint(fhour)).le.1
164           IF(LFNHR) THEN
165             KH=NINT(FHOUR)
166             NDIG=MAX(LOG10(KH+0.5)+1.,2.)
167             WRITE(CFORM,'("(I",I1,".",I1,")")') NDIG,NDIG
168             WRITE(CFHOUR,CFORM) KH
169           ELSE
170             KS=NINT(FHOUR*3600)
171             KH=KS/3600
172             KM=(KS-KH*3600)/60
173             KS=KS-KH*3600-KM*60
174             NDIG=MAX(LOG10(KH+0.5)+1.,2.)
175             WRITE(CFORM,
176          &      '("(I",I1,".",I1,",A1,I2.2,A1,I2.2)")') NDIG,NDIG
177             WRITE(CFHOUR,CFORM) KH,':',KM,':',KS
178           ENDIF
179           if( nfill(ens_nam) == 0 ) then
180           CFHOUR = CFHOUR(1:nfill(CFHOUR))
181           else
182           CFHOUR = CFHOUR(1:nfill(CFHOUR)) // ens_nam(1:nfill(ens_nam))
183           endif
184           if (me == ioproc)
185          &print *,' in wrtout_dynamics cfhour=',cfhour,' ens_nam=',ens_nam
186     !
187           nosig=61
188     !!
189           t3=rtc()
190           call MPI_BARRIER(mpi_comm_all,ierr)
191           t4=rtc()
192     !
193     C*** BUILD STATE ON EACH NODE ********
194     c build state on each node.   COMP tasks only
195     c assemble upair state first then sfc state,
196     c then (only if liope)  flux state.
197     !
198           t3=rtc()
199           if(mc_comp .ne. MPI_COMM_NULL) then
200     
201               do lan=1,lats_node_a
202                 jlonf = (lan-1)*lonf
203                 zsg(1:lonf,lan) = grid_gr(jlonf+1:jlonf+lonf,g_gz)
204               enddo
205               do k=1,levh
206                 do lan=1,lats_node_a
207                   jlonf = (lan-1)*lonf
208                   rqg(1:lonf,lan,k)=
209          &        grid_gr(jlonf+1:jlonf+lonf,g_rq-1+k)
210                 enddo
211               enddo
212     
213               do lan=1,lats_node_a
214                 lat      = global_lats_a(ipt_lats_node_a-1+lan)
215                 lons_lat = lonsperlat(lat)
216                 tx1      = one / coslat_a(lat)
217                 jlonf = (lan-1)*lonf
218     
219                 if (gen_coord_hybrid) then
220                   psg(1:lons_lat,lan) = grid_gr(jlonf+1:jlonf+lons_lat,g_q)
221                 else
222                   psg(1:lons_lat,lan) = 
223          &        exp(grid_gr(jlonf+1:jlonf+lons_lat,g_q))
224                 endif
225     
226                 if (gen_coord_hybrid) then        ! for general sigma-thera-p hybrid
227                   tki(:,1)       = 0.0
228                   tki(:,levs+1)  = 0.0
229                   do k=2,levs
230                     do i=1,lons_lat
231                       tkrt0 = ( grid_gr(i+jlonf,g_tt-1+k-1)
232          &                     +grid_gr(i+jlonf,g_tt-1+k) )
233          &                      /(thref(k-1)+thref(k))
234                       tki (i,k) = ck5(k)*tkrt0**rkappa
235                     enddo
236                   enddo
237                   do k=1,levs
238                     do i=1,lons_lat
239                       dpg(i,lan,k) = ak5(k)-ak5(k+1)+(bk5(k)-bk5(k+1))
240          &                     * psg(i,lan) + tki(i,k) - tki(i,k+1)
241                     enddo
242                   enddo
243                 elseif (hybrid) then              ! for sigma-p hybrid (ECWMF)
244                   do k=1,levs
245                     kk = levs - k + 1
246                     do i=1,lons_lat
247                       dpg(i,lan,k) = ak5(kk+1)-ak5(kk)
248          &                     + (bk5(kk+1)-bk5(kk)) * psg(i,lan)
249                     enddo
250                   enddo
251                 else                 ! For sigma coordinate
252                   do k=1,levs
253                     do i=1,lons_lat
254                       dpg(i,lan,k) = (si(k) - si(k+1)) * psg(i,lan)
255                     enddo
256                   enddo
257                 endif
258                 if (thermodyn_id == 3) then
259                   do k=1,levs
260                     do i=1,lons_lat
261                       tfac(i,k) = 0.0
262                       sumq(i,k) = 0.0
263                     enddo
264                   enddo
265                   do nn=1,ntrac
266                     nnl = (nn-1)*levs
267                     if (cpi(nn) .ne. 0.0) then
268                       do k=1,levs
269                         do i=1,lons_lat
270                           sumq(i,k) = sumq(i,k) + rqg(i,lan,nnl+k)
271                           tfac(i,k) = tfac(i,k) + cpi(nn)*rqg(i,lan,nnl+k)
272                         enddo
273                       enddo
274                     endif
275                   enddo
276                   do k=1,levs
277                     do i=1,lons_lat
278                       tfac(i,k) = (one-sumq(i,k))*cpi(0) + tfac(i,k)
279                     enddo
280                   enddo
281                 else
282                   do k=1,levs
283                     do i=1,lons_lat
284                       tfac(i,k) = one + fv*max(rqg(i,lan,k),qmin)
285                     enddo
286                   enddo
287                 endif
288                 do k=1,levs
289                   do i=1,lons_lat
290                     uug(i,lan,k) = grid_gr(i+jlonf,g_uu-1+k) * tx1
291                     vvg(i,lan,k) = grid_gr(i+jlonf,g_vv-1+k) * tx1
292                     ttg(i,lan,k) = grid_gr(i+jlonf,g_tt-1+k) / tfac(i,k)
293                   enddo
294                 enddo
295                 do k=1,levs
296                   do i=1,lons_lat
297                     dpg(i,lan,k) = cb2pa*dpg(i,lan,k)
298                   enddo
299                 enddo
300                 do i=1,lons_lat
301                   psg(i,lan) = cb2pa*psg(i,lan)
302                 enddo
303     
304               enddo
305     
306     
307           endif                 ! comp node
308     !
309     c  done with state build
310     c  NOW STATE IS ASSEMBLED ON EACH NODE.  GET EVERYTHING OFF THE COMPUTE
311     c  NODES (currently done with a send to the I/O task_
312     c  send state to I/O task.  All tasks
313     !
314             call grid_collect (zsg,psg,uug,vvg,ttg,rqg,dpg,
315          &                         global_lats_a,lonsperlat)
316     !jw      if (.not.quilting ) then
317     !jw         call atmgg_move(ioproc)
318     !
319     c ioproc only
320     !jw         CFHOUR1 = CFHOUR          !for the ESMF Export State Creation
321     !jw         ta=rtc()
322     !jw         if(me .eq. ioproc) then
323     !jw           CFORM = 'SIG.F'//CFHOUR
324     !jw           print *,' calling atmgg_wrt fhour=',fhour
325     !jw     &,                     ' cform=',cform,' idate=',idate
326     !jw           call atmgg_wrt(IOPROC,CFORM,fhour,idate
327     !jw     &,                global_lats_a,lonsperlat,pdryini)
328     !jw           print *,' returning fromatmgg_wrt=',fhour
329     !jw         endif
330     !jw      endif
331     !
332     !jw      tc=rtc()
333     !jw      if(me .eq. 0) t2=rtc()
334     cgwv  t2=rtc()
335     !jw      t3=rtc()
336     !jw      if(MC_COMP   .ne. MPI_COMM_NULL) then
337     !jw        call mpi_barrier(mc_comp,info)
338     !jw      endif
339     !
340     !      write(0,*)'me=',me,'ioproc=',ioproc,'fhour=',fhour
341           if(me .eq. ioproc)  call wrtlog_dynamics(phour,fhour,idate)
342     !jw      tb=rtc()
343     !jw      tf=tb-ta
344     !jw      t2=rtc()
345     !jw 1011 format(' WRTOUT_DYNAMICS TIME ',f10.4)
346     !jw      timesum=timesum+(t2-t1)
347     !jw 1012 format(
348     !jw     1 ' WRTOUT_DYNAMICS TIME ALL TASKS  ',f10.4,f10.4,
349     !jw     1 ' state, send, io  iobarr, (beginbarr),
350     !jw     1 spectbarr,open, openbarr )  ' ,
351     !jw     1  8f9.4)
352     !
353           return
354           end
355     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
356            SUBROUTINE wrt_restart_dynamics(TRIE_LS,TRIO_LS,grid_gr,
357          &        SI,fhour,idate,igen,pdryini,
358          x        ls_node,ls_nodes,max_ls_nodes,
359          &        global_lats_a,lonsperlat,lats_nodes_a,ens_nam,
360          &        kdt,nfcstdate7)
361     !
362           use gfs_dyn_resol_def
363           use gfs_dyn_layout1
364           use gfs_dyn_mpi_def
365     !
366           implicit none
367     !
368           real(kind=kind_evod) fhour
369           real(kind=kind_evod) pdryini
370           character (len=*)  :: ens_nam
371           character (255)  :: filename
372     !
373           integer              idate(4), igen
374           INTEGER              LS_NODE (LS_DIM*3)
375           integer              ls_nodes(ls_dim,nodes)
376           integer              max_ls_nodes(nodes)
377           integer kdt,nfcstdate7(7)
378      
379           real(kind=kind_evod) si(levp1)
380     !c
381           REAL(KIND=KIND_EVOD) TRIE_LS(LEN_TRIE_LS,2,lotls)
382           REAL(KIND=KIND_EVOD) TRIO_LS(LEN_TRIO_LS,2,lotls)
383           REAL(KIND=KIND_grid) grid_gr(lonf,lats_node_a_max,lotgr)
384     !!
385           INTEGER              GLOBAL_lats_a(latg)
386           INTEGER              lonsperlat(latg)
387           INTEGER              lats_nodes_a(nodes)
388     !
389     !-- local variables
390           integer IOPROC, IPRINT
391           integer needoro, iret, nfill
392     !!
393           IPRINT = 0
394           IOPROC=nodes-1
395     !
396           if (me == 0) print *,'in restart,lonsperlat=',lonsperlat
397     ! n time step spectral file
398     !
399           filename='SIGR1'
400           CALL TWRITES_rst(filename,ioproc,FHOUR,idate,
401          X                SI,LS_NODES,MAX_LS_NODES,
402          X                TRIE_LS(1,1,P_GZ), TRIE_LS(1,1,P_QM ),
403          X                TRIE_LS(1,1,P_TEM), TRIE_LS(1,1,P_DIM),
404          X                TRIE_LS(1,1,P_ZEM), TRIE_LS(1,1,P_RM),
405          X                TRIO_LS(1,1,P_GZ),TRIO_LS(1,1,P_QM ),
406          X                TRIO_LS(1,1,P_TEM), TRIO_LS(1,1,P_DIM),
407          X                TRIO_LS(1,1,P_ZEM), TRIO_LS(1,1,P_RM) )
408            if (me == 0) print *,'1 end of twritero_rst,',trim(filename)
409     !
410     ! n+1 time step spectral file
411     !
412           filename='SIGR2'
413           CALL TWRITES_rst(filename,ioproc,FHOUR,idate,
414          X                SI,LS_NODES,MAX_LS_NODES,
415          X                TRIE_LS(1,1,P_GZ), TRIE_LS(1,1,P_Q ),
416          X                TRIE_LS(1,1,P_TE), TRIE_LS(1,1,P_DI),
417          X                TRIE_LS(1,1,P_ZE), TRIE_LS(1,1,P_RQ),
418          X                TRIO_LS(1,1,P_GZ), TRIO_LS(1,1,P_Q ),
419          X                TRIO_LS(1,1,P_TE), TRIO_LS(1,1,P_DI),
420          X                TRIO_LS(1,1,P_ZE), TRIO_LS(1,1,P_RQ) )
421            if (me == 0) print *,'2 end of twritero_rst for ',trim(filename)
422     
423     ! n time step grid file
424     !
425            filename='GRDR1'
426            CALL TWRITEG_rst(filename,ioproc,FHOUR,idate,
427          X                SI,pdryini,global_lats_a,lonsperlat,lats_nodes_a,
428          &                grid_gr(1,1,g_qm),grid_gr(1,1,g_ttm),
429          &                grid_gr(1,1,g_uum),grid_gr(1,1,g_vvm),
430          &                grid_gr(1,1,g_rm),grid_gr(1,1,g_gz),
431          &    kdt,nfcstdate7 )
432             if (me == 0) print *,'1 end twriteg_rst,',trim(filename)
433     !
434     ! n+1 time step grid file
435     !
436           filename='GRDR2'
437           CALL TWRITEG_rst(filename,ioproc,FHOUR,idate,
438          X                SI,pdryini,global_lats_a,lonsperlat,lats_nodes_a,
439          &                grid_gr(1,1,g_q),grid_gr(1,1,g_tt),
440          &                grid_gr(1,1,g_uu),grid_gr(1,1,g_vv),
441          &                grid_gr(1,1,g_rq),grid_gr(1,1,g_gz),
442          &    kdt,nfcstdate7 )
443             if (me == 0) print *,'2 end twriteg_rst,',trim(filename)
444           call mpi_barrier(mpi_comm_all,iret)
445     !
446     
447           return
448           end
449     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
450           SUBROUTINE wrtlog_dynamics(phour,fhour,idate)
451           use gfs_dyn_resol_def
452           use namelist_dynamics_def
453           implicit none
454     
455           integer idate(4),ndigyr,nolog
456           integer ks,kh,km,ndig,nfill
457           character CFHOUR*40,CFORM*40
458           logical lfnhr
459           real phour,fhour
460     c
461     c     CREATE CFHOUR
462     
463     csela set lfnhr to false for writing one step output etc.
464           lfnhr=.true.    ! no output
465     ccmr  lfnhr=.false.   !    output
466     !      lfnhr=3600*abs(fhour-nint(fhour)).le.1.or.phour.eq.0
467           lfnhr=3600*abs(fhour-nint(fhour)).le.1
468           IF(LFNHR) THEN
469             KH=NINT(FHOUR)
470             NDIG=MAX(LOG10(KH+0.5)+1.,2.)
471             WRITE(CFORM,'("(I",I1,".",I1,")")') NDIG,NDIG
472             WRITE(CFHOUR,CFORM) KH
473             WRITE(CFORM,'("(I",I1,".",I1,")")') NDIG,NDIG
474             WRITE(CFHOUR,CFORM) KH
475           ELSE
476             KS=NINT(FHOUR*3600)
477             KH=KS/3600
478             KM=(KS-KH*3600)/60
479             KS=KS-KH*3600-KM*60
480             NDIG=MAX(LOG10(KH+0.5)+1.,2.)
481             WRITE(CFORM,
482          &      '("(I",I1,".",I1,",A1,I2.2,A1,I2.2)")') NDIG,NDIG
483             WRITE(CFHOUR,CFORM) KH,':',KM,':',KS
484           ENDIF
485           if( nfill(ens_nam) == 0 ) then
486           CFHOUR = CFHOUR(1:nfill(CFHOUR))
487           else
488           CFHOUR = CFHOUR(1:nfill(CFHOUR)) // ens_nam(1:nfill(ens_nam))
489           endif
490     !      print *,' in wrtlog_dynamics cfhour=',cfhour,' ens_nam=',ens_nam
491     
492           nolog=99
493           OPEN(NOlog,FILE='LOG.F'//CFHOUR,FORM='FORMATTED')
494           write(nolog,100)fhour,idate
495     100   format(' completed mrf fhour=',f10.3,2x,4(i4,2x))
496           CLOSE(NOlog)
497     
498           RETURN
499           END
500     
501     
502           subroutine  shapeset (ls_nodes,max_ls_nodes,pdryini)
503     !
504           use gfs_dyn_resol_def
505           use gfs_dyn_layout1
506           use namelist_dynamics_def
507           use gfs_dyn_mpi_def
508           implicit none
509     !
510           integer              ls_nodes(ls_dim,nodes)
511           integer              max_ls_nodes(nodes)
512     cc
513           integer              ierr,j,k,l,lenrec,locl,n,node
514     cc
515           integer              indjoff
516           integer              indev
517           integer              indod
518     cc
519           real(kind=kind_evod) gencode,order,ppid,realform
520           real(kind=kind_evod) subcen,tracers,trun,vcid,vmid,vtid
521     cc
522           real(kind=kind_evod) dummy(201-levp1-levs)
523           real(kind=kind_evod) ensemble(2),dummy2(18)
524     cc
525           real(kind=kind_io4)   tmps(4+nodes+jcap1*nodes)
526           real(kind=kind_io4)   tmpr(3+nodes+jcap1*(nodes-1))
527           REAL (KIND=KIND_grid) pdryini
528     cc
529           INTEGER              GLOBAL_lats_a(latg)
530           INTEGER                 lonsperlat(latg)
531     cc
532           integer  il,ilen,i,msgtag,ls_diml,nodesl,ioproc, itmpr
533                                                                                                             
534     c  Now define shape of the coefficients array
535     c  as a function of node. This will define how
536     c  to assemble the few wavenumbers on each node
537     c  into a full coefficient array.
538     c
539            IOPROC=nodes
540            IF (LIOPE) then
541      199    format(' GWVX MAX_LS_NODES ',i20)
542             if (me.eq.0.or. me .eq. ioproc) then
543             tmps=0.
544             tmps(1)=PDRYINI
545             tmps(2:nodes_comp+1)=max_ls_nodes(1:nodes_comp)
546             tmps(nodes_comp+2)=ls_dim
547             tmps(nodes_comp+3)=len_trie_ls_max
548             tmps(nodes_comp+4)=len_trio_ls_max
549             il=nodes_comp+4
550             do i=1,nodes_comp
551             do j=1,ls_dim
552                il=il+1
553                tmps(il)=ls_nodes(j,i)
554             enddo
555             enddo
556             ilen=4+nodes_comp+jcap1*nodes_comp
557             msgtag=2345
558             if(me .eq. 0) then
559                 CALL mpi_send(tmps,ilen,MPI_R_IO,ioproc,
560          &                msgtag,MPI_COMM_ALL,info)
561                endif
562             endif
563     !
564             if (me.eq.ioproc) then
565              ilen=4+nodes_comp+jcap1*(nodes_comp)
566              msgtag=2345
567                  CALL mpi_recv(tmpr,ilen,MPI_R_IO,0,
568          &                msgtag,MPI_COMM_ALL,stat,info)
569     
570               itmpr=3+nodes+jcap1*(nodes-1)
571               tmps(1:itmpr) = tmpr(1:itmpr)
572               ls_nodes=0
573               pdryini=tmps(1)
574               max_ls_nodes(1:nodes_comp)=int(tmps(2:nodes_comp+1))
575               ls_diml= int(tmps(nodes_comp+2))
576               len_trie_ls_max=int(tmps(nodes_comp+3))
577               len_trio_ls_max=int(tmps(nodes_comp+4))
578                il=nodes_comp+3+1
579                                                                                                             
580               do i=1,nodes_comp
581               do j=1,ls_diml
582                  il=il+1
583                  ls_nodes(j,i)=int(tmps(il))
584               enddo
585               enddo
586             endif
587           ENDIF
588     
589           return
590           end
591      
592     
593           INTEGER FUNCTION nfill(C)
594           implicit none
595           integer j
596           CHARACTER*(*) C
597           NFILL=LEN(C)
598           DO J=1,NFILL
599             IF(C(J:J).EQ.' ') THEN
600               NFILL=J-1
601               RETURN
602             ENDIF
603           ENDDO
604           RETURN
605           END
606      
607      
608