ROMS_r215: /home/cholod/wd/peps/ROMS/romsagrif_r215/Roms_tools/Roms

00001 !
00002 ! $Id: ncjoin.F,v 1.2 2003/12/17 13:56:04 pmarches Exp $
00003 !
00004       program ncjoin 
00005 !
00006 ! Generic netCDF assembly tool: reads partitioned netCDF files and
00007 ! assembles them into file corresponding to the whole corresonding
00008 ! to the whole physical grid. This operation is inverse to partit.
00009 !
00010       implicit none
00011       integer stdout, maxdims, maxvars, maxnodes
00012       parameter (stdout=6, maxdims=16, maxvars=64, maxnodes=64)
00013       character*64 ncname0, ncname(0:maxnodes-1), string
00014       character root*64, root_bak*64, sffx*8, sffx_bak*8
00015       character*32 dimname(maxdims), varname(maxvars)
00016       logical complete, digits, part_switch(maxvars),series(maxvars)
00017       integer narg, arg, iargc, NNODES, NP_XI, NP_ETA, i,j,k,m, ierr,
00018      &   lstr, lvar, lbak, lenstr, code_size, code_size_bak, node,
00019      &   ii(0:maxnodes), jj(0:maxnodes),  ncid0,  ncid(0:maxnodes),
00020      &   dimsize(maxdims,0:maxnodes), dimid(maxdims), varid(maxvars),
00021      &   vartype(maxvars), vardims(maxvars), dimids(maxdims,maxvars),
00022      &   ndims, nvars, ngatts, tsize, unlimdimid, varatts, size,
00023      &   id_xi_rho, id_xi_u, id_eta_rho, id_eta_v, rec,
00024      &   ibuff(maxdims),start(maxdims),count(maxdims),start1(maxdims)
00025 
00026       integer max_buff_size
00027       parameter (max_buff_size=300*300*30)
00028       real*8 buff(max_buff_size)
00029 #include "netcdf.inc"
00030 
00031 
00032 
00033       narg=iargc()
00034       arg=0
00035 !
00036 ! Extract a set of files which cover the whole physical grid.
00037 !
00038   1   NP_XI=-1                ! Reset variables which define
00039       NP_ETA=-1               ! partitioning policy: NP_XI,NP_ETA 
00040       do node=0,maxnodes-1    ! which are the dimensions of the 
00041         ii(node)=-1           ! processor grid as well as ii,jj 
00042         jj(node)=-1           ! (node) which are indices of node 
00043         ncid(node)=-1         ! on the processor grid. All these 
00044       enddo                   ! variables will be extracted from 
00045       root_bak(1:1)=' '       ! netCDF files and completness of 
00046       sffx_bak(1:1)=' '       ! all components will be verified. 
00047       code_size_bak=-1
00048   
00049   2    arg=arg+1
00050         call getarg(arg,ncname0)
00051         lstr=lenstr(ncname0)
00052         ierr=nf_open (ncname0(1:lstr), nf_nowrite, ncid0)
00053         if (ierr .eq. nf_noerr) then
00054           ierr=nf_inq_att (ncid0, nf_global, 'partition', i,lvar)
00055           if (ierr .eq. nf_noerr) then
00056             if (i.eq.nf_int .and. lvar.eq.4) then
00057               ierr=nf_get_att_int (ncid0,nf_global,'partition',ibuff)
00058               if (ierr .eq. nf_noerr) then
00059                 if (NP_XI.eq.-1 .and. NP_ETA.eq.-1) then
00060                   NP_XI =ibuff(3)
00061                   NP_ETA=ibuff(4)
00062                 elseif (NP_XI  .ne. ibuff(3)  .or.
00063      &                  NP_ETA .ne. ibuff(4)) then 
00064                   write(stdout,'(/8x,4A/2(17x,A,I2,A,I2,A/))')
00065      &                 'WARNING: Partitioning structure of netCDF',
00066      &                 'file ''', ncname0(1:lstr), ''',',
00067      &                 'NP_XI,NP_ETA =', ibuff(3),  ',',  ibuff(4),
00068      &                 ' conflicts with previously discovered',
00069      &                 'NP_XI,NP_ETA =',  NP_XI,  ',',  NP_ETA, '.'
00070                   arg=arg-1
00071                   goto 5
00072                 endif
00073                 i=ibuff(1)
00074                 j=ibuff(2)
00075                 node=i+j*NP_XI
00076                 if (ii(node).eq.-1 .and. jj(node).eq.-1) then
00077                   ii(node)=i
00078                   jj(node)=j
00079                   ncid(node)=ncid0
00080                   ncname(node)=ncname0
00081 !
00082 ! Lexical analysis of the file name: It is assumed that name of the
00083 ! file consists of root name (eg.: "history"); integer number which
00084 ! contains MPI node number (eg.: 03) and; suffix (eg.: ".nc").
00085 ! Files which belong to the same set normally have the same (1) root
00086 ! and (2) suffix names; the same (3) number of digits in the MPI node
00087 ! number segment in the filename and; (4) MPI node number from the
00088 ! file name should match the number determined from global attribute
00089 ! 'partition'. 
00090 !
00091                   root(1:1)=' '               ! Split file name into 
00092                   digits=.true.               ! root, MPI node number
00093                   i=lstr                      ! and suffix, if any.
00094                   j=0
00095    3              k=ichar(ncname0(i:i))
00096                   if (ncname0(i:i).eq.'.' .and. .not.digits) then
00097                     digits=.true.
00098                     j=i
00099                     sffx=ncname0(j:lstr)
00100                   elseif (ncname0(i:i).eq.'.' .and. digits) then
00101                     root=ncname0(1:i-1)
00102                   elseif (k.lt.48 .or. k.gt.57) then
00103                     digits=.false.
00104                   endif  
00105                   if (root(1:1).eq.' ' .and. i.gt.1) then
00106                     i=i-1
00107                     goto 3
00108                   endif
00109 
00110                   if (j.gt.0) then            ! Setting suffix name,
00111                     sffx=ncname0(j:lstr)      ! if there is a suffix.
00112                   else                        !
00113                     sffx(1:1)=' '
00114                   endif
00115  
00116                   code_size=max(0,j-i-1)      ! Determine MPI node
00117                   k=0                         ! number according to 
00118    4              i=i+1                       ! the file name. 
00119                   if (i.lt.j) then
00120                     k=10*k+ichar(ncname0(i:i))-48
00121                     goto 4
00122                   endif
00123 c**               write(*,'(2I3,1x,A)') code_size, k, ncname0(1:lstr)
00124 !
00125 ! Checking consistency of root name with previously found.
00126 !
00127                   ierr=nf_noerr
00128                   if (root_bak(1:1).eq.' ') then
00129                     root_bak=root
00130                   else
00131                     lvar=lenstr(root)
00132                     lbak=lenstr(root_bak)
00133                     if (lvar.ne.lbak .or. root.ne.root_bak) then
00134                       ierr=ierr+1
00135                       write(stdout,'(/8x,7A/17x,3A/)') 'WARNING: ',
00136      &                  'file ''',    ncname0(1:lstr),   ''' has ',
00137      &                  'different root name ''',     root(1:lvar),
00138      &                  ''' than', 'previously found root name ''',
00139      &                  root_bak(1:lbak),   ''' from the same set.'
00140                     endif
00141                   endif
00142 !
00143 ! Checking consistency of suffix with previously found..
00144 !
00145                   if (sffx_bak(1:1).eq.' ') then
00146                     sffx_bak=sffx
00147                   else
00148                     lvar=lenstr(sffx)
00149                     lbak=lenstr(sffx_bak)
00150                     if (lvar.ne.lbak .or. sffx.ne.sffx_bak) then
00151                       ierr=ierr+1
00152                       write(stdout,'(/8x,7A/17x,3A/)') 'WARNING: ',
00153      &                  'file ''',     ncname0(1:lstr),   ''' has ',
00154      &                  'different suffix name ''',    sffx(1:lvar),
00155      &                  ''' than','previously found suffix name ''',
00156      &                  sffx_bak(1:lbak),   ''' from the same set.'
00157                     endif
00158                   endif
00159 !
00160 ! Checking consistency of length of node number segment
00161 !
00162                   if (code_size_bak.eq.-1) then
00163                     code_size_bak=code_size
00164                   elseif (code_size .ne. code_size_bak) then
00165                     ierr=ierr+1
00166                     write(stdout,'(/8x,A,I2,1x,A/17x,3A,I2,A/)')
00167      &              'WARNING: number of digits in MPI node segment',
00168      &               code_size,'in file name', '''',ncname0(1:lstr),
00169      &              ''' is different than previously determined',
00170      &              code_size_bak, '.' 
00171                   endif
00172 
00173 
00174 !
00175 ! Checking consistency of node number with the file name.
00176 !
00177                   if (k.ne.node) then
00178                     ierr=ierr+1
00179                     write(stdout,'(/8x,3A,I3/17x,2A/17x,A,I3,A/)')
00180      &                   'WARNING: file ''', ncname0(1:lstr), 
00181      &                   ''' belongs to different MPI node',   node,
00182      &                   '(as determined from its global attribute',
00183      &                   '''partition'')', 'than node', k,
00184      &                   ' determined from to the file name.'
00185                   endif
00186 !
00187 ! Stop, if something is wrong.
00188 !
00189                   if (ierr.ne.nf_noerr) goto 97
00190                 else
00191                   write(stdout,'(/8x,3A/17x,A,I2,A,I2,A/)')
00192      &               'WARNING: netCDF file ''',    ncname0(1:lstr),
00193      &               ''' corresponds to subdomain','ii,jj =',i,',',
00194      &               j,  ' which already defined in another file.'
00195                   arg=arg-1
00196                   goto 5
00197                 endif
00198               else 
00199                 write(stdout,'(/8x,2A/17x,4A/)') 'WARNING: Cannot ',
00200      &                'aquire global attribute ''partition'' from ',
00201      &                'netCDF file ''',  ncname0(1:lstr),    '''. ',
00202      &                'This file is ignored.'
00203               endif
00204             else
00205               write(stdout,'(/8x,2A/17x,3A/)') 'WARNING: ',
00206      &          'incompatible type and/or size of global attribute',
00207      &          '''partition'' in netCDF file ''',  ncname0(1:lstr),
00208      &          '''. This file is ignored.'
00209             endif
00210           else
00211             write(stdout,'(/8x,3A/17x,A/)')'WARNING: netCDF file ''',
00212      &              ncname0(1:lstr), ''' is not a partitioned file,',
00213      &                                        'This file is ignored.'
00214           endif 
00215         else
00216           write(stdout,'(/8x,A,1x,3A/)') 'WARNING: Cannot open',
00217      &                  'netCDF file ''', ncname0(1:lstr), '''.'
00218         endif
00219         if (arg.lt.narg) goto 2
00220 !
00221 ! Verify, whether ncname,ncid(0:NP_XI*NP_ETA-1) comprizes a complete
00222 ! set of partitioned files.
00223 !
00224    5    complete=.true.
00225         do node=0,NP_XI*NP_ETA-1 
00226           if (ncid(node).lt.0) complete=.false.
00227         enddo
00228         if (complete) then
00229           lvar=lenstr(ncname(0))
00230           write(stdout,'(4x,2A,I2,1x,A,2(3x,A,I2))') 'Processing ',
00231      &       'set of files', 0, ncname(0)(1:lvar), 'NP_XI =', NP_XI,
00232      &                                            'NP_ETA =', NP_ETA
00233           do node=1,NP_XI*NP_ETA-1
00234            write(stdout,'(25x,I4,1x,A)')node, ncname(node)(1:lvar)
00235           enddo
00236           write(stdout,*)
00237         elseif (arg.lt.narg) then
00238           goto 1
00239         else
00240           stop 
00241         endif
00242 
00243         NNODES=NP_XI*NP_ETA
00244 !
00245 ! General inquiry into the file which belongs to subdomain ii,jj=0,0
00246 !
00247         lstr=lenstr(ncname(0))
00248         ierr=nf_inq (ncid(0), ndims, nvars, ngatts, unlimdimid)
00249         if (ierr .ne. nf_noerr) then
00250           write(stdout,'(/8x,2A/15x,3A/)')   'ERROR: Cannot ',
00251      &            'determine number of dimensions, variables',
00252      &            'and attributes in netCDF file ''', 
00253      &                              ncname(0)(1:lstr),   '''.'
00254           goto 97
00255         elseif (ndims .gt. maxdims) then
00256           write(stdout,'(/8x,A,I4,1x,4A/15x,A,1x,A/)')
00257      &        'ERROR: number of dimensions', ndims,  'in netCDF',
00258      &        'file ''', ncname(0)(1:lstr), '''', 'exceeds limit.',
00259      &        'Increase parameter maxdims in file "partit.F".'
00260           goto 97
00261          elseif (nvars .gt. maxvars) then
00262           write(stdout,'(/8x,A,I4,1x,4A/15x,A,1x,A/)')
00263      &        'ERROR: number of variables',  nvars,  'in netCDF',
00264      &        'file ''', ncname(0)(1:lstr), '''', 'exceeds limit.',
00265      &        'Increase parameter maxvars in file "partit.F".'
00266           goto 97
00267         endif
00268 !
00269 ! Verify that ndims, nvars, ngatts, unlimdimid are the same for
00270 ! all of the nodes.
00271 !
00272         do node=1,NNODES-1
00273           ierr=nf_inq (ncid(node), ibuff(1), ibuff(2),
00274      &                             ibuff(3), ibuff(4))
00275           if (ierr .ne. nf_noerr) then
00276             write(stdout,'(/8x,2A/15x,3A/)')   'ERROR: Cannot ',
00277      &              'determine number of dimensions, variables',
00278      &              'and attributes in netCDF file ''', 
00279      &                             ncname(node)(1:lstr),   '''.'
00280             goto 97
00281           elseif (ibuff(1) .ne. ndims) then
00282             write(stdout,'(/8x,3A/15x,3A/)') 'ERROR: netCDF file ''',
00283      &               ncname(node)(1:lstr), ''' has different number',
00284      &              'of dimensions than ''', ncname(0)(1:lstr), '''.'
00285             goto 97
00286           elseif (ibuff(2) .ne. nvars) then
00287             write(stdout,'(/8x,3A/15x,3A/)') 'ERROR: netCDF file ''',
00288      &               ncname(node)(1:lstr), ''' has different number',
00289      &              'of variables than ''',  ncname(0)(1:lstr), '''.'
00290             goto 97
00291           elseif (ibuff(3) .ne. ngatts) then
00292             write(stdout,'(/8x,3A/15x,3A/)') 'ERROR: netCDF file ''',
00293      &               ncname(node)(1:lstr), ''' has different number',
00294      &              'of global attributes than ''',
00295      &                                       ncname(0)(1:lstr), '''.'
00296             goto 97
00297           elseif (ibuff(4) .ne. unlimdimid) then
00298             write(stdout,'(/8x,3A/15x,3A/)') 'ERROR: netCDF file ''',
00299      &               ncname(node)(1:lstr), ''' has different ID',
00300      &              'for unlimited dimension than ''',
00301      &                                       ncname(0)(1:lstr), '''.'
00302             goto 97
00303           endif
00304         enddo 
00305 !
00306 ! Check dimensions (IDs, names and sizes) for consistency accross
00307 ! the subdomains:
00308 !
00309         do i=1,ndims
00310           do node=0,NNODES-1
00311             ierr=nf_inq_dimname (ncid(node), i, string)
00312             if (ierr .ne. nf_noerr) then
00313               write(stdout,'(/8x,2A,I3/15x,3A/)')     'ERROR: ',
00314      &          'Cannot determine name for dimension ID =',   i,
00315      &          'in netCDF file ''', ncname(node)(1:lstr), '''.'
00316               goto 97
00317             else
00318               j=lenstr(string) 
00319               if (node.eq.0) then
00320                 lvar=j
00321                 dimname(i)=string(1:j)
00322               elseif (lvar.ne.j .or. dimname(i)(1:lvar)  .ne.
00323      &                                      string(1:j)) then
00324                 write(stdout,'(/8x,4A,I3/3(15x,3A/))') 'ERROR: ',
00325      &            'name ''',string(1:j),''' of dimension with ID =',
00326      &            i, 'in netCDF file ''',    ncname(node)(1:lstr),
00327      &            ''' does not match',   'dimension name ''',
00328      &            dimname(i)(1:lvar), ''' with the same ID in',
00329      &            'netCDF file ''',   ncname(0)(1:lstr),    '''.'
00330                   goto 97
00331               endif
00332             endif
00333             ierr=nf_inq_dimlen  (ncid(node), i, dimsize(i,node))
00334             if (ierr .ne. nf_noerr) then
00335               write(stdout,'(/8x,A,1x,3A/15x,3A/)')  'ERROR: Cannot', 
00336      &          'determine size of dimension ''', dimname(i)(1:lvar),
00337      &          '''', 'in netCDF file ''', ncname(node)(1:lstr),'''.'
00338               goto 97
00339             endif
00340           enddo
00341 !
00342 ! Set dimension size for the combined file the same as similar
00343 ! dimension for subdomain of MPI node 0. Then for partitionable
00344 ! dimensions 'xi_rho', 'xi_u', 'eta_rho' and 'eta_v' scan files
00345 ! for subdomains adjacent in corresponding directions (XI- for
00346 ! 'xi_rho', 'xi_u' and ETA-direction for 'eta_rho', 'eta_v') and
00347 ! add up their dimension sizes.
00348 ! For all other dimensions, verify that the sizes are the same
00349 ! for all nodes. Also find size of unlimited dimension.
00350 !
00351           dimsize(i,NNODES)=dimsize(i,0)
00352           if (lvar.eq.6 .and. dimname(i)(1:lvar).eq.'xi_rho') then 
00353             id_xi_rho=i
00354             do node=1,NP_XI-1
00355               dimsize(i,NNODES)=dimsize(i,NNODES)+dimsize(i,node)
00356             enddo
00357           elseif (lvar.eq.4 .and. dimname(i)(1:lvar).eq.'xi_u') then
00358             id_xi_u=i
00359             do node=1,NP_XI-1
00360               dimsize(i,NNODES)=dimsize(i,NNODES)+dimsize(i,node)
00361             enddo
00362           elseif (lvar.eq.7.and.dimname(i)(1:lvar).eq.'eta_rho') then 
00363             id_eta_rho=i
00364             do node=NP_XI, NP_XI*NP_ETA-1, NP_XI
00365               dimsize(i,NNODES)=dimsize(i,NNODES)+dimsize(i,node)
00366             enddo
00367           elseif (lvar.eq.5 .and. dimname(i)(1:lvar).eq.'eta_v') then
00368             id_eta_v=i
00369             do node=NP_XI, NP_XI*NP_ETA-1, NP_XI
00370               dimsize(i,NNODES)=dimsize(i,NNODES)+dimsize(i,node)
00371             enddo
00372           else
00373             do node=1,NNODES-1
00374               if (dimsize(i,0).ne.dimsize(i,node)) then
00375                 write(stdout,'(/8x,A,I4,3A,I3/15x,3A/15x,A,I4,3A/)')
00376      &           'ERROR: Size',  dimsize(i,node), ' of dimension ''',
00377      &            dimname(i)(1:lvar),   ''' with ID =',  i,
00378      &           'in netCDF file ''',   ncname(node)(1:lstr),
00379      &           ''' does not match',  'similar size',  dimsize(i,0),
00380      &           ' from file file ''',  ncname(0)(1:lstr),  '''.'
00381                goto 97
00382               endif
00383             enddo
00384           endif
00385           if (i.eq. unlimdimid) then
00386             tsize=dimsize(i,NNODES)
00387             dimsize(i,NNODES)=nf_unlimited
00388           endif
00389         enddo ! <-- i loop over dimensions
00390 !                              
00391 ! Create combined netCDF file:  Once the completeness of the set of
00392 ! ====== ======== ====== =====  partial files have been established
00393 !                               and dimensions survive consistency
00394 !                               check, create the combined file,
00395 !                               define its dimensions and copy
00396 !                               global attributes.
00397         i=lenstr(root_bak)
00398         j=lenstr(sffx_bak)
00399         ncname0=root_bak(1:i)/ /sffx_bak(1:j)
00400         lstr=lenstr(ncname0)
00401         ierr=nf_create ( ncname0(1:lstr), nf_clobber, ncid0)
00402         if (ierr .eq. nf_noerr) then
00403           write(stdout,'(8x,3A)')  'Created netCDF file ''',
00404      &                                ncname0(1:lstr), '''.'
00405         else
00406           write(stdout,'(/8x,4A/)') 'ERROR: Cannot create ',
00407      &              'netCDF file ''', ncname0(1:lstr), '''.'
00408           goto 97
00409         endif
00410 !
00411 ! Define dimensions
00412 !
00413         do i=1,ndims
00414           lvar=lenstr(dimname(i))
00415           ierr=nf_def_dim (ncid0, dimname(i)(1:lvar),
00416      &                     dimsize(i,NNODES), dimid(i))
00417           if (ierr .ne. nf_noerr) then
00418             write(stdout,'(/8x,4A/15x,A,I4,A/)') 'ERROR: Cannot ',
00419      &           'define dimension ''', dimname(i)(1:lvar), '''.', 
00420      &           'netCDF ettor status =', ierr, '.'
00421             goto 97
00422           elseif (dimid(i).ne.i) then
00423             write(stdout,'(/8x,4A/15x,A/)') 'ERROR: dimension ',
00424      &        'ID from file ''', ncname0(1:lstr),  ''' differs',
00425      &        'from the original ID.'
00426             goto 97
00427           endif
00428 c**       write(*,'(2I3,I5,1x,A)') i, dimid(i), dimsize(i,NNODES), 
00429 c**  &                                          dimname(i)(1:lvar)
00430         enddo ! <-- i loop over dimensions
00431 !
00432 ! Copy global attributes (except 'partition').
00433 !
00434         do i=1,ngatts
00435           ierr=nf_inq_attname (ncid(0), nf_global, i, string)
00436           if (ierr. eq. nf_noerr) then
00437             lvar=lenstr(string)
00438             if (string(1:lvar) .ne. 'partition') then 
00439               ierr=nf_copy_att (ncid(0), nf_global, string(1:lvar),
00440      &                                            ncid0, nf_global)
00441               if (ierr. ne. nf_noerr) then
00442                 write(stdout,'(/8x,4A/15x,3A/)')  'ERROR: Cannot ',
00443      &            'copy global attribute ''', string(1:lvar), '''',
00444      &            'into netCDF file ''',   ncname0(1:lstr),   '''.'
00445                goto 97
00446               endif
00447             endif 
00448           else
00449             lstr=lenstr(ncname(0))
00450             write(stdout,'(/8x,2A,I3/15x,3A/)') 'ERROR: Cannot ',
00451      &         'determine mame of global attribute with ID =', i,
00452      &         'from netCDF file ''',   ncname(0)(1:lstr),  '''.'
00453             goto 97
00454           endif
00455         enddo
00456 !
00457 ! Define variables and copy their attributes.
00458 !
00459         do i=1,nvars
00460           ierr=nf_inq_var (ncid(0),   i, varname(i),  vartype(i),
00461      &                        vardims(i), dimids(1,i),   varatts)
00462           if (ierr .eq. nf_noerr) then
00463             lvar=lenstr(varname(i))
00464             ierr=nf_def_var (ncid0, varname(i)(1:lvar), vartype(i),
00465      &                           vardims(i), dimids(1,i), varid(i))
00466             if (ierr .eq. nf_noerr) then
00467               do j=1,varatts
00468                 ierr=nf_inq_attname (ncid(0), varid(i), j, string)
00469                 if (ierr .eq. nf_noerr) then
00470                   lvar=lenstr(string)
00471                   ierr=nf_copy_att (ncid(0), i, string(1:lvar),
00472      &                                           ncid0, varid(i))
00473                   if (ierr. ne. nf_noerr) then
00474                     write(stdout,'(/8x,2A,I3,3A/15x,3A/)') 'ERROR: ',
00475      &                  'Cannot copy attribute with ID =',   j,
00476      &                  ' for variable ''', varname(i)(1:lvar), '''',
00477      &                  'into netCDF file ''', ncname0(1:lstr), '''.'
00478                     goto 97
00479                   endif
00480                 else
00481                   write(stdout,'(/8x,2A,I3/15x,3A)')     'ERROR: ',
00482      &                 'Cannot acquire attribute with ID =',  j,
00483      &                 'for variable ''', varname(i)(1:lvar), '''.'
00484                   goto 97
00485                 endif
00486               enddo
00487             else
00488               write(stdout,'(/8x,4A/)') 'ERROR: Cannot define ',
00489      &                  'variable ''', varname(i)(1:lvar), '''.'
00490               goto 97
00491             endif
00492           else
00493             lstr=lenstr(ncname(0))
00494             write(stdout,'(/8x,2A/15x,A,I3,1x,3A/)')'ERROR: Cannot ',
00495      &            'determine name, type and attributes for variable',
00496      &            'with ID =', i, 'from netCDF file ''', 
00497      &                                      ncname(0)(1:lstr),  '''.'
00498             goto 97
00499           endif
00500 !
00501 ! Determine whether partitionable dimensions or unlimited dimension
00502 ! are present for this variable.
00503 !
00504           series(i)=.false.
00505           part_switch(i)=.false.
00506           do j=1,vardims(i)
00507             if (dimids(j,i).eq.id_xi_rho .or.
00508      &          dimids(j,i).eq.id_xi_u    .or.
00509      &          dimids(j,i).eq.id_eta_rho .or.
00510      &          dimids(j,i).eq.id_eta_v) then
00511               part_switch(i)=.true.
00512             elseif (dimids(j,i).eq.unlimdimid) then
00513               series(i)=.true.
00514             endif
00515           enddo
00516         enddo       ! <-- i, variable ID.
00517 !
00518 ! Leave definition mode
00519 !
00520         ierr=nf_enddef (ncid0)
00521 !
00522 ! Transfer variables into newly created file.
00523 !
00524         do rec=1,tsize
00525           if (tsize.gt.1) write(stdout,'(16x,A,I5,1x,A)')
00526      &                     'Processing record', rec, '...'
00527           do i=1,nvars
00528             if (series(i) .or. rec.eq.1) then
00529               if (.not.part_switch(i) .and. .not.series(i)) then
00530 !
00531 ! Scalar (zero-dimensional) variables:
00532 !
00533 c**             write(*,*) 'Scalar variable ', varname(i)
00534                 if (vartype(i) .eq. nf_char) then
00535                   ierr=nf_get_var_text  (ncid(0), i, buff)
00536                 elseif (vartype(i) .eq. nf_int) then
00537                   ierr=nf_get_var_int    (ncid(0), i, buff)
00538                 elseif (vartype(i) .eq. nf_real) then
00539                   ierr=nf_get_var_real   (ncid(0), i, buff)
00540                 elseif (vartype(i) .eq. nf_double) then
00541                   ierr=nf_get_var_double (ncid(0), i, buff)
00542                 else
00543                   lvar=lenstr(varname(i))
00544                   write(stdout,'(/8x,4A/)') 'ERROR: scalar variable',
00545      &              ' ''', varname(i)(1:lvar), ''' has unknown type.'
00546                   goto 97
00547                 endif
00548                 if (ierr .eq. nf_noerr) then
00549                   if (vartype(i) .eq. nf_char) then
00550                     ierr=nf_put_var_text  (ncid0, varid(i), buff)
00551                   elseif (vartype(i) .eq. nf_int) then
00552                     ierr=nf_put_var_int    (ncid0, varid(i), buff)
00553                   elseif (vartype(i) .eq. nf_real) then
00554                     ierr=nf_put_var_real   (ncid0 ,varid(i), buff)
00555                   elseif (vartype(i) .eq. nf_double) then
00556                     ierr=nf_put_var_double (ncid0, varid(i), buff)
00557                   endif
00558                   if (ierr .ne. nf_noerr) then
00559                     lvar=lenstr(varname(i))
00560                     write(stdout,'(/8x,4A/15x,4A,I4,A/)') 'ERROR: ',
00561      &                        'Cannot write scalar variable ''',
00562      &                         varname(i)(1:lvar), ''' into netCDF',
00563      &                        'file ''', ncname0(1:lstr), '''.  ',
00564      &                        'netCDF error status code =', ierr,'.'
00565                     goto 97
00566                   endif
00567                 else
00568                   lvar=lenstr(varname(i))
00569                   write(stdout,'(/8x,4A/)') 'ERROR: Cannot read ',
00570      &             'scalar variable ''', varname(i)(1:lvar), '''.'
00571                   goto 97
00572                 endif
00573               elseif (.not.part_switch(i)) then
00574 !
00575 ! Non-partitionable array.
00576 !
00577 c**             write(*,*) 'Non-partitionable array ', varname(i)
00578                 size=1
00579                 do j=1,vardims(i)
00580                   if (dimids(j,i).eq.unlimdimid) then
00581                     start(j)=rec
00582                     count(j)=1
00583                   else
00584                     start(j)=1
00585                     count(j)=dimsize(dimids(j,i),0)
00586                   endif
00587                   size=size*count(j)
00588                 enddo
00589                 if (vartype(i) .eq. nf_char) then
00590                   size=size*1
00591                 elseif (vartype(i) .eq. nf_int) then
00592                   size=size*4
00593                 elseif (vartype(i) .eq. nf_real) then
00594                   size=size*4
00595                 elseif (vartype(i) .eq. nf_double) then
00596                   size=size*8
00597                 else
00598                   lvar=lenstr(varname(i))
00599                   write(stdout,'(/8x,3A/)') 'ERROR: variable ''',
00600      &                 varname(i)(1:lvar), ''' has unknown type.'
00601                   goto 97
00602                 endif
00603                 if (size .gt. 8*max_buff_size) then
00604                   write(stdout,'(/8x,A,3(/15x,A,I10,1x,A)/)')
00605      &             'ERROR: unsufficient buffer size in "ncjoin.F":',
00606      &             'requested:',         size,      'Bytes,',
00607      &             'available:',   8*max_buff_size, 'Bytes.',
00608      &             'Increase parameter max_buff_size and recompile.'
00609                   goto 97
00610                 endif
00611 
00612                if (vartype(i) .eq. nf_char) then
00613                   ierr=nf_get_vara_text   (ncid(0), i, start,
00614      &                                           count, buff)
00615                 elseif (vartype(i) .eq. nf_int) then
00616                   ierr=nf_get_vara_int    (ncid(0), i, start,
00617      &                                           count, buff)
00618                 elseif (vartype(i) .eq. nf_real) then
00619                   ierr=nf_get_vara_real   (ncid(0), i, start,
00620      &                                           count, buff)
00621                 elseif (vartype(i) .eq. nf_double) then
00622                   ierr=nf_get_vara_double (ncid(0), i, start,
00623      &                                           count, buff)
00624                 endif
00625                 if (ierr .eq. nf_noerr) then
00626                   if (vartype(i) .eq. nf_char) then
00627                     ierr=nf_put_vara_text   (ncid0, varid(i),
00628      &                                         start, count, buff)
00629                   elseif (vartype(i) .eq. nf_int) then
00630                     ierr=nf_put_vara_int    (ncid0, varid(i),
00631      &                                         start, count, buff)
00632                   elseif (vartype(i) .eq. nf_real) then
00633                     ierr=nf_put_vara_real   (ncid0, varid(i),
00634      &                                         start, count, buff)
00635                   elseif (vartype(i) .eq. nf_double) then
00636                     ierr=nf_put_vara_double (ncid0, varid(i),
00637      &                                         start, count, buff)
00638                   endif
00639                   if (ierr .ne. nf_noerr) then
00640                     lvar=lenstr(varname(i))
00641                     write(stdout,'(/8x,4A,I3/15x,3A,I3/)') 'ERROR: ',
00642      &               'Cannot write variable ''',  varname(i)(1:lvar),
00643      &               ''' for time record',rec, 'into netCDF file ''',
00644      &               ncname0(1:lstr),'''. netCDF error code =', ierr
00645                     goto 97
00646                   endif
00647                 else
00648                   lvar=lenstr(varname(i))
00649                   write(stdout,'(/8x,4A,I3,A/15x,A,I4/)') 'ERROR: ',
00650      &               'Cannot read variable ''',  varname(i)(1:lvar),
00651      &               ''' for time record', rec, '.',
00652      &                           'netCDF error status code =', ierr
00653                   goto 97
00654                 endif
00655               elseif (part_switch(i)) then
00656 !
00657 ! Partitioned array:
00658 !
00659 c**             write(*,*) 'Partitioned array ', varname(i)
00660                 do node=0,NNODES-1
00661                   size=1
00662                   do j=1,vardims(i)
00663                     k=dimids(j,i)
00664                     if (k.eq.id_xi_rho .or. k.eq.id_xi_u) then
00665                       start(j)=1
00666                       count(j)=dimsize(k,node)
00667                       start1(j)=1
00668                       do m=0,ii(node)-1
00669                         start1(j)=start1(j)+dimsize(k,m)
00670                       enddo
00671 
00672                     elseif (k.eq.id_eta_rho .or. k.eq.id_eta_v) then
00673                       start(j)=1
00674                       count(j)=dimsize(k,node)
00675                       start1(j)=1
00676                       do m=0,jj(node)-1
00677                         start1(j)=start1(j)+dimsize(k,m*NP_XI)
00678                       enddo
00679 
00680                     elseif (k.eq.unlimdimid) then
00681                       start(j)=rec
00682                       count(j)=1
00683                       start1(j)=rec
00684                     else
00685                       start(j)=1
00686                       count(j)=dimsize(k,nnodes)
00687                       start1(j)=1
00688                     endif
00689                     size=size*count(j)
00690 c**                 if (k.eq.id_eta_rho) write(*,'(A,1x, 6I6)')
00691 c**  &                 varname(i)(1:lvar), node,ii(node),jj(node),
00692 C**  &                            j, start1(j), dimsize(k,nnodes)
00693                   enddo
00694                   if (vartype(i) .eq. nf_char) then
00695                     size=size*1
00696                   elseif (vartype(i) .eq. nf_int) then
00697                     size=size*4
00698                   elseif (vartype(i) .eq. nf_real) then
00699                     size=size*4
00700                   elseif (vartype(i) .eq. nf_double) then
00701                     size=size*8
00702                   else
00703                     lvar=lenstr(varname(i))
00704                     write(stdout,'(/8x,4A/)') 'ERROR: variable ''',
00705      &                   varname(i)(1:lvar), ''' has unknown type.'
00706                     goto 97
00707                   endif
00708                   if (size .gt. 8*max_buff_size) then
00709                     write(stdout,'(/8x,A,3(/15x,A,I10,1x,A)/)')
00710      &             'ERROR: unsufficient buffer size in "ncjoin.F":',
00711      &             'requested:',         size,      'Bytes,',
00712      &             'available:',   8*max_buff_size, 'Bytes.',
00713      &             'Increase parameter max_buff_size and recompile.'
00714                     goto 97
00715                   endif
00716 
00717                   if (vartype(i) .eq. nf_char) then
00718                     ierr=nf_get_vara_text   (ncid(node), i, start,
00719      &                                                count, buff)
00720                   elseif (vartype(i) .eq. nf_int) then
00721                     ierr=nf_get_vara_int    (ncid(node), i, start,
00722      &                                                count, buff)
00723                   elseif (vartype(i) .eq. nf_real) then
00724                     ierr=nf_get_vara_real   (ncid(node), i, start,
00725      &                                                count, buff)
00726                   elseif (vartype(i) .eq. nf_double) then
00727                     ierr=nf_get_vara_double (ncid(node), i, start,
00728      &                                                count, buff)
00729                   endif
00730                   if (ierr .eq. nf_noerr) then
00731                     if (vartype(i) .eq. nf_char) then
00732                       ierr=nf_put_vara_text   (ncid0, varid(i),
00733      &                                        start1, count, buff)
00734                     elseif (vartype(i) .eq. nf_int) then
00735                       ierr=nf_put_vara_int    (ncid0, varid(i),
00736      &                                        start1, count, buff)
00737                     elseif (vartype(i) .eq. nf_real) then
00738                       ierr=nf_put_vara_real   (ncid0, varid(i),
00739      &                                        start1, count, buff)
00740                     elseif (vartype(i) .eq. nf_double) then
00741                       ierr=nf_put_vara_double (ncid0, varid(i),
00742      &                                        start1, count, buff)
00743                     endif
00744                     if (ierr .ne. nf_noerr) then
00745                       lvar=lenstr(varname(i))
00746                       write(stdout,'(/8x,3A,I3/15x,3A,I3/)')
00747      &                  'ERROR: Cannot write variable ''',
00748      &                   varname(i)(1:lvar), ''' for time record',
00749      &                   rec,    'into file ''',  ncname0(1:lstr),
00750      &                   '''. netCDF error status code =',  ierr
00751                       goto 97
00752                     endif
00753                   else
00754                     lvar=lenstr(varname(i))
00755                     lstr=lenstr(ncname(node))
00756                     write(stdout,'(/8x,4A,I3/15x,3A,I4/)') 'ERROR: ',
00757      &                 'Cannot read variable ''', varname(i)(1:lvar),
00758      &                ''' for time record',    rec,   'from file ''',
00759      &                ncname(node)(1:lstr),
00760      &                               '''. netCDF error code =', ierr
00761                     goto 97
00762                   endif
00763 
00764 
00765                 enddo       ! <-- node=0,NNODES-1
00766               endif
00767             endif
00768           enddo
00769         enddo
00770 !
00771 ! Close all files
00772 !
00773   97    ierr=nf_close (ncid0) 
00774         do node=0,NNODES-1
00775           ierr=nf_close (ncid(node))
00776         enddo
00777        if (arg .lt. narg)  goto 1  !--> next set of partial files.
00778       stop
00779       end
00780
/home/cholod/wd/peps/ROMS/romsagrif_r215/Roms_tools/Roms_Agrif/ncjoin.F
