text:
        subroutine error (routin, variab, num)
c
c----------------------------------------------------------------------
c
c This utility routine prints out the error and stops the program.
c
c input:
c  routin       : name of the routine where the error occurred
c  variab       : an 8-character error message
c  num          : any integer number associated with the error
c
c Farzin Shakib, Summer 1985.
c----------------------------------------------------------------------
c
        include "commonM2NFixBnd.h"
        include "mpif.h"
c
        character*8 routin, variab
c
        data ierchk /0/
c
c.... check for redundant error
c
        if (ierchk .eq. 1) stop
        ierchk = 1

        if(myrank.eq.master) then
c
c.... open file
c
           ferror='error.log'
           open (unit=ierror, file=ferror, status='unknown')
c
c.... print the error
c
           write (*,1000) title, routin, variab, num
           if (num .ne. 0) write (ierror,1000) title, routin, variab,num
           if (num .eq. 0) write (ierror,1000) title, routin, variab
c
c.... halt the process
c
           close (ierror)
        endif

c        WRITE(6,'(A,G14.6)') 'Life: ',death - birth

        if (numpe > 1) then
           call MPI_ABORT(MPI_COMM_WORLD)
        endif

1000    format(' ',a80,//,
     &         ' ****** Error occurred in routine <',a8,'>',/,
     &          '  Error code :',a8,:,' : ',i8,//)
        end


text:
module types
  type base_type
     private               !-- Sets default accessibility
     integer :: i          !-- a private component
     integer, private :: j !-- another private component
     integer, public :: k  !-- a public component
  end type base_type

  type, extends(base_type) :: my_type
     private               !-- Sets default for components declared in my_type
     integer :: l          !-- A private component.
     integer, public :: m  !-- A public component.
  end type my_type

end module types

subroutine sub
  use types
  type(my_type) :: x

  ! this multi-line causes the parser to fail because of the comments
  ! following the '&'.  the new-line character after the comment is left in
  ! the stream and is not ignored, so the lexical prepass assumes that is the
  ! T_EOS.  the newline needs to be ignored in this case, and it probably has
  ! to be done in FortranStream or FortranLexer, but certainly before the
  ! FortranLexicalPrepass.
  call another_sub(   &
       x%base_type,   & !-- ok because base_type is a public subobject of x
       x%base_type%k, & !-- ok because x%base_type is ok and has k as a
                        !-- public component.
       x%k,           & !-- ok because it is a shorthand for x%base_type%k
       x%base_type%i, & !-- Invalid because i is private.
       x%i)             !-- Invalid because it is shorthand for x%base_type%i
end subroutine sub

max_stars_repo_name: OpenFortranProject/ofp-sdf

max_issues_repo_name: OpenFortranProject/ofp-sdf

max_forks_repo_name: OpenFortranProject/ofp-sdf


text:
C
C Copyright (c) 1980 The Regents of the University of California.
C All rights reserved.
C
C %sccs.include.proprietary.f%
C
C	@(#)flid.f	5.2 (Berkeley) 04/12/91
C

	program flid
	external f77lid
	end

ext: f

max_stars_repo_name: weiss/original-bsd

max_issues_repo_name: JamesLinus/original-bsd

max_forks_repo_name: JamesLinus/original-bsd


text:
!!  Copyright (C)  Stichting Deltares, 2012-2016.
!!
!!  This program is free software: you can redistribute it and/or modify
!!  it under the terms of the GNU General Public License version 3,
!!  as published by the Free Software Foundation.
!!
!!  This program is distributed in the hope that it will be useful,
!!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!!  GNU General Public License for more details.
!!
!!  You should have received a copy of the GNU General Public License
!!  along with this program. If not, see <http://www.gnu.org/licenses/>.
!!
!!  contact: delft3d.support@deltares.nl
!!  Stichting Deltares
!!  P.O. Box 177
!!  2600 MH Delft, The Netherlands
!!
!!  All indications and logos of, and references to registered trademarks
!!  of Stichting Deltares remain the property of Stichting Deltares. All
!!  rights reserved.

module putget_mod
!
!  Generic module for putget operations on NEFIS files
!
!  module declarations
!
!
!  data definition module(s)
!
use precision_part          ! single and double precisionv
      use timers
!
!  module procedure(s)
!
use noextspaces_mod    ! explicit interface for subroutine calls
!
implicit none          ! force explicit typing
!
interface putget
    module procedure putget_int      ! for reading/ writing integer (scalar)
    module procedure putget_int1D    ! for reading/ writing integer 1D arrays
    module procedure putget_int2D    ! for reading/ writing integer 2D arrays
    module procedure putget_real     ! for reading/ writing real (scalar)
    module procedure putget_real1D   ! for reading/ writing real 1D arrays
    module procedure putget_real2D   ! for reading/ writing real 2D arrays
    module procedure putget_char     ! for reading/ writing character (scalar)
    module procedure putget_char1D   ! for reading/ writing character arrays
end interface
!
!   module data
!
!
    integer(ip), parameter             :: start=1 ,stopp=2 ,incr=3
    integer(ip), parameter             :: no_groups = 5
!
    integer(ip)                        :: buflen,elmndm
    integer(ip)                        :: inef  ,ierror,  jnef
    integer(ip)                        :: lelmnr
    integer(ip)                        :: nnef
    integer(ip)                        :: igr
!
    integer(ip)                        :: datlen
    integer(ip)                        :: deflen
    integer(ip),dimension(10)          :: usrord
    integer(ip),dimension(3,no_groups) :: uindex
    integer(ip),dimension(5)           :: elmdim
!
    character(len=    1)               :: access
    character(len=    1)               :: coding
    character(len=    8)               :: elmtap
    character(len=   16)               :: elmqta,elmant
    character(len=   64)               :: elmdas
    character(len=  256)               :: datnam
    character(len=  256)               :: defnam
    character(len= 1023)               :: errstr
!
!-external functions
!
      integer(ip)       ::  clsnef, credat, crenef, defcel, defelm,  &
                            defgrp, getelt, inqelm, neferr, putelt,  &
                            putels, getels
      external          ::  clsnef, credat, crenef, defcel, defelm,  &
                            defgrp, getelt, inqelm, neferr, putelt,  &
                            putels, getels
!
      save           fd_nef
      integer(ip) :: fd_nef = -1

contains
!---------------------------------------------------------------------------
!     putget_int : specific procedure for reading/ writing an INTEGER
!---------------------------------------------------------------------------
      subroutine putget_int (filnam    ,grpnam    ,nelems    ,elt_names    ,   &
                             elt_dims  ,elt_types ,elt_bytes ,elmnam       ,   &
                             celidt    ,wrilog    ,error     ,ibuffr     )
!
      integer(ip),dimension( :, :)       :: elt_dims
      integer(ip),dimension( :)          :: elt_bytes
      integer(ip)                        :: celidt,nelems,error
!
      integer(ip)                        :: ibuffr
      integer(ip),dimension(1)           :: buffr      ! array is placed on stack
      character(len=*),dimension(:)      :: elt_names,elt_types
      character(len=*)                   :: elmnam,filnam,grpnam
!
      logical                            :: wrilog
      integer(4) ithndl              ! handle to time this subroutine
      data       ithndl / 0 /
      if ( timon ) call timstrt( "putget_int", ithndl )
!
      buffr(1) = ibuffr
!
!-----initialization
!
      coding        = 'n'
      elmndm        = 5
      do igr=1,no_groups
         usrord(igr)       = 1
         uindex(start,igr) = celidt
         uindex(stopp,igr) = celidt
         uindex(incr,igr)  = 1
      end do

!
!-----aggregate file names
!
      datnam = trim(filnam) // '.dat'
      call noextspaces(datnam,datlen)

      defnam = trim(filnam) // '.def'
      call noextspaces(defnam,deflen)
!
!-----write or read data from nefis files
!
      if (wrilog) then
        access = 'u'
      else
        access = 'r'
      endif
!
      error  = crenef (fd_nef, datnam(1:datlen), defnam(1:deflen), &
                               coding, access)
      if (error /= 0 .and. .not.wrilog) then
        error = -211
        goto 9999
      endif
      if ( error /= 0 ) goto 9999

      if (wrilog) then
        error  = putelt(fd_nef,grpnam,elmnam,  &
                        uindex,1     ,buffr        )
      else
        jnef=0
 123    continue
          jnef=jnef+1
          if (elmnam  ==  elt_names(jnef)) goto 124
          goto 123
 124    continue
        buflen = elt_bytes(jnef) ! size single precision integer
        do inef= 1, elt_dims(1,jnef)
          buflen = buflen*elt_dims(inef+1,jnef)
        enddo

        error  = getelt(fd_nef,grpnam,elmnam,uindex,usrord,buflen,buffr)
        if (error /= 0) goto 9999
      endif
!
!-----error:
!     writing: most likely error non existing group, so define it
!     reading: error, no error expected
!
      if ( error  /=  0 .and. wrilog ) then
! create elements
        do 110 lelmnr=1,nelems
          error  = defelm(fd_nef        ,elt_names(  lelmnr),      &
                          elt_types(lelmnr),elt_bytes(  lelmnr),      &
                          ' ' ,' ',                             &
                          ' ' ,elt_dims(1,lelmnr),                &
                          elt_dims(2,lelmnr)               )
!      most likely error, element already exist
          error = 0
  110   continue
! create cells
        error  = defcel(fd_nef,grpnam,nelems,elt_names)
        if ( error  /=  0 ) goto 9999
! create group on definition file
        error  = defgrp(fd_nef,grpnam,grpnam,1,0,1)
        if ( error  /=  0 ) goto 9999
! create group on data       file
        error  = credat(fd_nef,grpnam,grpnam)
        if ( error  /=  0 ) goto 9999
! try again to write data
        error  = putelt(fd_nef,grpnam,elmnam, &
                        uindex,1     ,buffr        )
        if ( error  /=  0 ) goto 9999
      endif
!
!     no error when reading elements
!
      if (error == 0 .and. .not.wrilog) then
        error = inqelm(fd_nef,elmnam,elmtap,buflen,  &
                       elmqta,elmant,elmdas,elmndm,elmdim)

        if (error   /=  0) goto 9999
        lelmnr = 0
        do 210 nnef = 1,nelems
           if (elmnam  ==  elt_names(nnef)) then
              lelmnr = nnef
              goto 220
           endif
  210   continue
  220   continue
        if (lelmnr /= 0) goto 9999
!
        do 230 inef = 1,elmndm
!
!----------compare local and global dimensions, not equal
!          => new error number and exit
!
           if (elmdim(inef)  /=  elt_dims(1+inef,lelmnr)) then
              error  = -15025
              goto 9999
           endif
  230   continue
      endif
      goto 10000
!
 9999 continue
      if (error  /=  0) then
         ierror = neferr(1, errstr)
        write(*,*) trim(errstr)
      endif
10000 continue
      ierror = clsnef( fd_nef )
!
      if ( timon ) call timstop ( ithndl )
      return
      end subroutine putget_int

!-----------------------------------------------------------------------------
!     putget_int1D: specific procedure for reading/ writing 1D integer arrays
!-----------------------------------------------------------------------------
      subroutine putget_int1D(filnam    ,grpnam    ,nelems    ,elt_names   ,   &
                              elt_dims  ,elt_types ,elt_bytes ,elmnam      ,   &
                              celidt    ,wrilog    ,error     ,buffr     )
      implicit none
!
      integer(ip),dimension(:,:)     :: elt_dims
      integer(ip),dimension(  :)     :: elt_bytes
      integer(ip)                    :: celidt,nelems,error
!
      integer(ip),dimension(:)       :: buffr
      character(len=*),dimension(:)  :: elt_names,elt_types
      character(len=*)               :: elmnam,filnam,grpnam
!
      logical                        :: wrilog
!
      save       fd_nef
      integer :: fd_nef = -1
      integer(4) ithndl              ! handle to time this subroutine
      data       ithndl / 0 /
      if ( timon ) call timstrt( "putget_int1D", ithndl )
!
!-----initialization
!
      coding        = 'n'
      elmndm        = 5
      do igr=1,no_groups
         usrord(igr)       = 1
         uindex(start,igr) = celidt
         uindex(stopp,igr) = celidt
         uindex(incr,igr)  = 1
      end do
!
!-----aggregate file names
!
      datnam = trim(filnam) // '.dat'
      call noextspaces(datnam,datlen)

      defnam = trim(filnam) // '.def'
      call noextspaces(defnam,deflen)
!
!-----write or read data from nefis files
!
      if (wrilog) then
        access = 'u'
      else
        access = 'r'
      endif
!
      error  = crenef (fd_nef, datnam(1:datlen), defnam(1:deflen), &
                               coding, access)
      if (error /= 0 .and. .not.wrilog) then
        error = -211
        goto 9999
      endif
      if ( error /= 0 ) goto 9999

      if (wrilog) then
        error  = putelt(fd_nef,grpnam,elmnam,  &
                        uindex,1     ,buffr        )
      else
        jnef=0
 123    continue
          jnef=jnef+1
          if (elmnam  ==  elt_names(jnef)) goto 124
          goto 123
 124    continue
        buflen = elt_bytes(jnef) ! size single precision integer
        do inef= 1, elt_dims(1,jnef)
          buflen = buflen*elt_dims(inef+1,jnef)
        enddo

        error  = getelt(fd_nef,grpnam,elmnam,uindex,usrord,buflen,buffr)
        if (error /= 0) goto 9999
      endif
!
!-----error:
!     writing: most likely error non existing group, so define it
!     reading: error, no error expected
!
      if ( error  /=  0 .and. wrilog ) then
! create elements
        do 110 lelmnr=1,nelems
          error  = defelm(fd_nef        ,elt_names(  lelmnr),      &
                          elt_types(lelmnr),elt_bytes(  lelmnr),      &
                          ' ' ,' ',                             &
                          ' ' ,elt_dims(1,lelmnr),                &
                          elt_dims(2,lelmnr)               )
!      most likely error, element already exist
          error = 0
  110   continue
! create cells
        error  = defcel(fd_nef,grpnam,nelems,elt_names)
        if ( error  /=  0 ) goto 9999
! create group on definition file
        error  = defgrp(fd_nef,grpnam,grpnam,1,0,1)
        if ( error  /=  0 ) goto 9999
! create group on data       file
        error  = credat(fd_nef,grpnam,grpnam)
        if ( error  /=  0 ) goto 9999
! try again to write data
        error  = putelt(fd_nef,grpnam,elmnam, &
                        uindex,1     ,buffr        )
        if ( error  /=  0 ) goto 9999
      endif
!
!     no error when reading elements
!
      if (error == 0 .and. .not.wrilog) then
        error = inqelm(fd_nef,elmnam,elmtap,buflen,  &
                       elmqta,elmant,elmdas,elmndm,elmdim)

        if (error   /=  0) goto 9999
        lelmnr = 0
        do 210 nnef = 1,nelems
           if (elmnam  ==  elt_names(nnef)) then
              lelmnr = nnef
              goto 220
           endif
  210   continue
  220   continue
        if (lelmnr /= 0) goto 9999
!
        do 230 inef = 1,elmndm
!
!----------compare local and global dimensions, not equal
!          => new error number and exit
!
           if (elmdim(inef)  /=  elt_dims(1+inef,lelmnr)) then
              error  = -15025
              goto 9999
           endif
  230   continue
      endif
      goto 10000
!
 9999 continue
      if (error  /=  0) then
         ierror = neferr(1, errstr)
        write(*,*) trim(errstr)
      endif
10000 continue
      ierror = clsnef( fd_nef )
!
      if ( timon ) call timstop ( ithndl )
      return
      end subroutine putget_int1D

!-----------------------------------------------------------------------------
!     putget_int2D: specific procedure for reading/ writing 2D integer arrays
!-----------------------------------------------------------------------------
      subroutine putget_int2D(filnam    ,grpnam     ,nelems    ,elt_names    ,   &
                              elt_dims  ,elt_types  ,elt_bytes ,elmnam       ,   &
                              celidt    ,wrilog     ,error     ,ibuffr      )
      implicit none
!
      integer(ip),dimension(:,:)                            :: elt_dims
      integer(ip),dimension(:)                              :: elt_bytes
      integer(ip)                                           :: celidt,nelems,error
!
      integer(ip),dimension(:,:)                            :: ibuffr
      integer(ip),dimension(:), allocatable                 :: buffr ! to prevent that the array is placed on the stack
      character(len=*),dimension(:)                         :: elt_names,elt_types
      character(len=*)                                      :: elmnam,filnam,grpnam
!
      logical                                               :: wrilog
!
      save       fd_nef
      integer :: fd_nef = -1
      integer :: k
      integer(4) ithndl              ! handle to time this subroutine
      data       ithndl / 0 /
      if ( timon ) call timstrt( "putget_int2D", ithndl )
!
!     First transform 2D into 1D work array
!
      allocate(buffr(size(ibuffr)))
!
!     buffr = reshape(ibuffr,(/size(ibuffr)/))  ! done on the stack
      k = 0
      do jnef = 1, size(ibuffr,2)
          do inef = 1, size(ibuffr,1)
              k = k+1
              buffr(k) = ibuffr(inef,jnef)
          enddo
      enddo
!
!-----initialization
!
      coding        = 'n'
      elmndm        = 5
      do igr=1,no_groups
         usrord(igr)       = 1
         uindex(start,igr) = celidt
         uindex(stopp,igr) = celidt
         uindex(incr,igr)  = 1
      end do
!
!-----aggregate file names
!
      datnam = trim(filnam) // '.dat'
      call noextspaces(datnam,datlen)

      defnam = trim(filnam) // '.def'
      call noextspaces(defnam,deflen)
!
!-----write or read data from nefis files
!
      if (wrilog) then
        access = 'u'
      else
        access = 'r'
      endif
!
      error  = crenef (fd_nef, datnam(1:datlen), defnam(1:deflen), &
                               coding, access)
      if (error /= 0 .and. .not.wrilog) then
        error = -211
        goto 9999
      endif
      if ( error /= 0 ) goto 9999

      if (wrilog) then
        error  = putelt(fd_nef,grpnam,elmnam,  &
                        uindex,1     ,buffr        )
      else
        jnef=0
 123    continue
          jnef=jnef+1
          if (elmnam  ==  elt_names(jnef)) goto 124
          goto 123
 124    continue
        buflen = elt_bytes(jnef) ! size single precision integer
        do inef= 1, elt_dims(1,jnef)
          buflen = buflen*elt_dims(inef+1,jnef)
        enddo

        error  = getelt(fd_nef,grpnam,elmnam,uindex,usrord,buflen,buffr)
        if (error /= 0) goto 9999
      endif
!
!-----error:
!     writing: most likely error non existing group, so define it
!     reading: error, no error expected
!
      if ( error  /=  0 .and. wrilog ) then
! create elements
        do 110 lelmnr=1,nelems
          error  = defelm(fd_nef        ,elt_names(  lelmnr),      &
                          elt_types(lelmnr),elt_bytes(  lelmnr),      &
                          ' ' ,' ',                             &
                          ' ' ,elt_dims(1,lelmnr),                &
                          elt_dims(2,lelmnr)               )
!      most likely error, element already exist
          error = 0
  110   continue
! create cells
        error  = defcel(fd_nef,grpnam,nelems,elt_names)
        if ( error  /=  0 ) goto 9999
! create group on definition file
        error  = defgrp(fd_nef,grpnam,grpnam,1,0,1)
        if ( error  /=  0 ) goto 9999
! create group on data       file
        error  = credat(fd_nef,grpnam,grpnam)
        if ( error  /=  0 ) goto 9999
! try again to write data
        error  = putelt(fd_nef,grpnam,elmnam, &
                        uindex,1     ,buffr        )
        if ( error  /=  0 ) goto 9999
      endif
!
!     no error when reading elements
!
      if (error == 0 .and. .not.wrilog) then
        error = inqelm(fd_nef,elmnam,elmtap,buflen,  &
                       elmqta,elmant,elmdas,elmndm,elmdim)

        if (error   /=  0) goto 9999
        lelmnr = 0
        do 210 nnef = 1,nelems
           if (elmnam  ==  elt_names(nnef)) then
              lelmnr = nnef
              goto 220
           endif
  210   continue
  220   continue
        if (lelmnr /= 0) goto 9999
!
        do 230 inef = 1,elmndm
!
!----------compare local and global dimensions, not equal
!          => new error number and exit
!
           if (elmdim(inef)  /=  elt_dims(1+inef,lelmnr)) then
              error  = -15025
              goto 9999
           endif
  230   continue
      endif
      goto 10000
!
 9999 continue
      if (error  /=  0) then
         ierror = neferr(1, errstr)
        write(*,*) trim(errstr)
      endif
10000 continue
      ierror = clsnef( fd_nef )
!
      if ( timon ) call timstop ( ithndl )
      return
      end subroutine putget_int2D

!---------------------------------------------------------------------------
!     putget_real : specific procedure for reading/ writing a REAL
!---------------------------------------------------------------------------
      subroutine putget_real                                               &
                       (filnam    ,grpnam     ,nelems    ,elt_names    ,   &
                        elt_dims  ,elt_types  ,elt_bytes ,elmnam       ,   &
                        celidt    ,wrilog     ,error     ,rbuffr     )
      implicit none
!
!
      integer(ip),dimension(:,:)     :: elt_dims
      integer(ip),dimension(:)       :: elt_bytes
      integer(ip)                    :: celidt,nelems,error
!
      real(sp)                       :: rbuffr
      real(sp),dimension(1)          :: buffr      ! array is placed on stack
      character(len=*),dimension(:)  :: elt_names , elt_types
      character(len=*)               :: elmnam,filnam,grpnam
!
      logical                        :: wrilog
!
      save       fd_nef
      integer :: fd_nef = -1
      integer(4) ithndl              ! handle to time this subroutine
      data       ithndl / 0 /
      if ( timon ) call timstrt( "putget_real", ithndl )
!
      buffr(1) = rbuffr
!
!-----initialization
!
      coding        = 'n'
      elmndm        = 5
      do igr=1,no_groups
         usrord(igr)       = 1
         uindex(start,igr) = celidt
         uindex(stopp,igr) = celidt
         uindex(incr,igr)  = 1
      end do
!
!-----aggregate file names
!
      datnam = trim(filnam) // '.dat'
      call noextspaces(datnam,datlen)

      defnam = trim(filnam) // '.def'
      call noextspaces(defnam,deflen)
!
!-----write or read data from nefis files
!
      if (wrilog) then
        access = 'u'
      else
        access = 'r'
      endif
!
      error  = crenef (fd_nef, datnam(1:datlen), defnam(1:deflen),   &
                               coding, access)
      if (error /= 0 .and. .not.wrilog) then
        error = -211
        goto 9999
      endif
      if ( error /= 0 ) goto 9999

      if (wrilog) then
        error  = putelt(fd_nef,grpnam,elmnam,    &
                        uindex,1     ,buffr        )
      else
        jnef=0
 123    continue
          jnef=jnef+1
          if (elmnam  ==  elt_names(jnef)) goto 124
          goto 123
 124    continue
        buflen = elt_bytes(jnef) ! size single precision integer
        do inef= 1, elt_dims(1,jnef)
          buflen = buflen*elt_dims(inef+1,jnef)
        enddo

        error  = getelt(fd_nef,grpnam,elmnam,uindex,usrord,buflen,buffr)
        if (error /= 0) goto 9999
      endif
!
!-----error:
!     writing: most likely error non existing group, so define it
!     reading: error, no error expected
!
      if ( error  /=  0 .and. wrilog ) then
! create elements
        do 110 lelmnr=1,nelems
          error  = defelm(fd_nef        ,elt_names(  lelmnr),   &
                          elt_types(lelmnr),elt_bytes(  lelmnr),   &
                          ' ' ,' ',                          &
                          ' ' ,elt_dims(1,lelmnr),             &
                          elt_dims(2,lelmnr)               )
!      most likely error, element already exist
          error = 0
  110   continue
! create cells
        error  = defcel(fd_nef,grpnam,nelems,elt_names)
        if ( error  /=  0 ) goto 9999
! create group on definition file
        error  = defgrp(fd_nef,grpnam,grpnam,1,0,1)
        if ( error  /=  0 ) goto 9999
! create group on data       file
        error  = credat(fd_nef,grpnam,grpnam)
        if ( error  /=  0 ) goto 9999
! try again to write data
        error  = putelt(fd_nef,grpnam,elmnam,   &
                        uindex,1     ,buffr        )
        if ( error  /=  0 ) goto 9999
      endif
!
!     no error when reading elements
!
      if (error == 0 .and. .not.wrilog) then
        error = inqelm(fd_nef,elmnam,elmtap,buflen,   &
                       elmqta,elmant,elmdas,elmndm,elmdim)

        if (error   /=  0) goto 9999
        lelmnr = 0
        do 210 nnef = 1,nelems
           if (elmnam  ==  elt_names(nnef)) then
              lelmnr = nnef
              goto 220
           endif
  210   continue
  220   continue
        if (lelmnr /= 0) goto 9999
!
        do 230 inef = 1,elmndm
!
!----------compare local and global dimensions, not equal
!          => new error number and exit
!
           if (elmdim(inef)  /=  elt_dims(1+inef,lelmnr)) then
              error  = -15025
              goto 9999
           endif
  230   continue
      endif
      goto 10000
!
 9999 continue
      if (error  /=  0) then
         ierror = neferr(1, errstr)
        write(*,*) trim(errstr)
      endif
10000 continue
      ierror = clsnef( fd_nef )
!
      if ( timon ) call timstop ( ithndl )
      return
      end subroutine putget_real

!---------------------------------------------------------------------------
!     putget_real1D: specific procedure for reading/ writing 1D real arrays
!---------------------------------------------------------------------------
      subroutine putget_real1D                                            &
                       (filnam    ,grpnam    ,nelems    ,elt_names    ,   &
                        elt_dims  ,elt_types ,elt_bytes ,elmnam       ,   &
                        celidt    ,wrilog    ,error     ,buffr     )
      implicit none
!
!
      integer(ip),dimension(:,:)     :: elt_dims
      integer(ip),dimension(:)       :: elt_bytes
      integer(ip)                    :: celidt,nelems,error
!
      real(sp),dimension(:)          :: buffr
      character(len=*),dimension(:)  :: elt_names , elt_types
      character(len=*)               :: elmnam,filnam,grpnam
!
      logical                        :: wrilog
!
      save       fd_nef
      integer :: fd_nef = -1
      integer(4) ithndl              ! handle to time this subroutine
      data       ithndl / 0 /
      if ( timon ) call timstrt( "putget_real1D", ithndl )
!
!-----initialization
!
      coding        = 'n'
      elmndm        = 5
      do igr=1,no_groups
         usrord(igr)       = 1
         uindex(start,igr) = celidt
         uindex(stopp,igr) = celidt
         uindex(incr,igr)  = 1
      end do
!
!-----aggregate file names
!
      datnam = trim(filnam) // '.dat'
      call noextspaces(datnam,datlen)

      defnam = trim(filnam) // '.def'
      call noextspaces(defnam,deflen)
!
!-----write or read data from nefis files
!
      if (wrilog) then
        access = 'u'
      else
        access = 'r'
      endif
!
      error  = crenef (fd_nef, datnam(1:datlen), defnam(1:deflen),   &
                               coding, access)
      if (error /= 0 .and. .not.wrilog) then
        error = -211
        goto 9999
      endif
      if ( error /= 0 ) goto 9999

      if (wrilog) then
        error  = putelt(fd_nef,grpnam,elmnam,    &
                        uindex,1     ,buffr        )
      else
        jnef=0
 123    continue
          jnef=jnef+1
          if (elmnam  ==  elt_names(jnef)) goto 124
          goto 123
 124    continue
        buflen = elt_bytes(jnef) ! size single precision integer
        do inef= 1, elt_dims(1,jnef)
          buflen = buflen*elt_dims(inef+1,jnef)
        enddo

        error  = getelt(fd_nef,grpnam,elmnam,uindex,usrord,buflen,buffr)
        if (error /= 0) goto 9999
      endif
!
!-----error:
!     writing: most likely error non existing group, so define it
!     reading: error, no error expected
!
      if ( error  /=  0 .and. wrilog ) then
! create elements
        do 110 lelmnr=1,nelems
          error  = defelm(fd_nef        ,elt_names(  lelmnr),   &
                          elt_types(lelmnr),elt_bytes(  lelmnr),   &
                          ' ' ,' ',                          &
                          ' ' ,elt_dims(1,lelmnr),             &
                          elt_dims(2,lelmnr)               )
!      most likely error, element already exist
          error = 0
  110   continue
! create cells
        error  = defcel(fd_nef,grpnam,nelems,elt_names)
        if ( error  /=  0 ) goto 9999
! create group on definition file
        error  = defgrp(fd_nef,grpnam,grpnam,1,0,1)
        if ( error  /=  0 ) goto 9999
! create group on data       file
        error  = credat(fd_nef,grpnam,grpnam)
        if ( error  /=  0 ) goto 9999
! try again to write data
        error  = putelt(fd_nef,grpnam,elmnam,   &
                        uindex,1     ,buffr        )
        if ( error  /=  0 ) goto 9999
      endif
!
!     no error when reading elements
!
      if (error == 0 .and. .not.wrilog) then
        error = inqelm(fd_nef,elmnam,elmtap,buflen,   &
                       elmqta,elmant,elmdas,elmndm,elmdim)

        if (error   /=  0) goto 9999
        lelmnr = 0
        do 210 nnef = 1,nelems
           if (elmnam  ==  elt_names(nnef)) then
              lelmnr = nnef
              goto 220
           endif
  210   continue
  220   continue
        if (lelmnr /= 0) goto 9999
!
        do 230 inef = 1,elmndm
!
!----------compare local and global dimensions, not equal
!          => new error number and exit
!
           if (elmdim(inef)  /=  elt_dims(1+inef,lelmnr)) then
              error  = -15025
              goto 9999
           endif
  230   continue
      endif
      goto 10000
!
 9999 continue
      if (error  /=  0) then
         ierror = neferr(1, errstr)
        write(*,*) trim(errstr)
      endif
10000 continue
      ierror = clsnef( fd_nef )
!
      if ( timon ) call timstop ( ithndl )
      return
      end subroutine putget_real1D

!---------------------------------------------------------------------------
!     putget_real1D: specific procedure for reading/ writing 2D real arrays
!---------------------------------------------------------------------------
      subroutine putget_real2D                                          &
                       (filnam    ,grpnam    ,nelems    ,elt_names  ,   &
                        elt_dims  ,elt_types ,elt_bytes ,elmnam     ,   &
                        celidt    ,wrilog    ,error     ,rbuffr     )
      implicit none
!
!
      integer(ip),dimension(:,:)                          :: elt_dims
      integer(ip),dimension(:)                            :: elt_bytes
      integer(ip)                                         :: celidt,nelems,error
!
      real(sp),dimension(:,:)                             :: rbuffr
      real(sp),dimension(:), allocatable                  :: buffr ! to prevent that the array is placed on the stack
      character(len=*),dimension(:)                       :: elt_names , elt_types
      character(len=*)                                    :: elmnam,filnam,grpnam
!
      logical                                             :: wrilog
!
      save       fd_nef
      integer :: fd_nef = -1
      integer :: k
      integer(4) ithndl              ! handle to time this subroutine
      data       ithndl / 0 /
      if ( timon ) call timstrt( "putget_real2D", ithndl )
!
!     First transform 2D into 1D work array
!
      allocate(buffr(size(rbuffr)))

!     buffr = reshape(rbuffr,(/size(rbuffr)/))     ! done on the stack
      k=0
      do jnef = 1, size(rbuffr,2)
          do inef = 1, size(rbuffr,1)
              k = k+1
              buffr(k) = rbuffr(inef,jnef)
          enddo
      enddo
!
!-----initialization
!
      coding        = 'n'
      elmndm        = 5
      do igr=1,no_groups
         usrord(igr)       = 1
         uindex(start,igr) = celidt
         uindex(stopp,igr) = celidt
         uindex(incr,igr)  = 1
      end do
!
!-----aggregate file names
!
      datnam = trim(filnam) // '.dat'
      call noextspaces(datnam,datlen)

      defnam = trim(filnam) // '.def'
      call noextspaces(defnam,deflen)
!
!-----write or read data from nefis files
!
      if (wrilog) then
        access = 'u'
      else
        access = 'r'
      endif
!
      error  = crenef (fd_nef, datnam(1:datlen), defnam(1:deflen),   &
                               coding, access)
      if (error /= 0 .and. .not.wrilog) then
        error = -211
        goto 9999
      endif
      if ( error /= 0 ) goto 9999

      if (wrilog) then
        error  = putelt(fd_nef,grpnam,elmnam,    &
                        uindex,1     ,buffr        )
      else
        jnef=0
 123    continue
          jnef=jnef+1
          if (elmnam  ==  elt_names(jnef)) goto 124
          goto 123
 124    continue
        buflen = elt_bytes(jnef) ! size single precision integer
        do inef= 1, elt_dims(1,jnef)
          buflen = buflen*elt_dims(inef+1,jnef)
        enddo

        error  = getelt(fd_nef,grpnam,elmnam,uindex,usrord,buflen,buffr)
        if (error /= 0) goto 9999
      endif
!
!-----error:
!     writing: most likely error non existing group, so define it
!     reading: error, no error expected
!
      if ( error  /=  0 .and. wrilog ) then
! create elements
        do 110 lelmnr=1,nelems
          error  = defelm(fd_nef        ,elt_names(  lelmnr),   &
                          elt_types(lelmnr),elt_bytes(  lelmnr),   &
                          ' ' ,' ',                          &
                          ' ' ,elt_dims(1,lelmnr),             &
                          elt_dims(2,lelmnr)               )
!      most likely error, element already exist
          error = 0
  110   continue
! create cells
        error  = defcel(fd_nef,grpnam,nelems,elt_names)
        if ( error  /=  0 ) goto 9999
! create group on definition file
        error  = defgrp(fd_nef,grpnam,grpnam,1,0,1)
        if ( error  /=  0 ) goto 9999
! create group on data       file
        error  = credat(fd_nef,grpnam,grpnam)
        if ( error  /=  0 ) goto 9999
! try again to write data
        error  = putelt(fd_nef,grpnam,elmnam,   &
                        uindex,1     ,buffr        )
        if ( error  /=  0 ) goto 9999
      endif
!
!     no error when reading elements
!
      if (error == 0 .and. .not.wrilog) then
        error = inqelm(fd_nef,elmnam,elmtap,buflen,   &
                       elmqta,elmant,elmdas,elmndm,elmdim)

        if (error   /=  0) goto 9999
        lelmnr = 0
        do 210 nnef = 1,nelems
           if (elmnam  ==  elt_names(nnef)) then
              lelmnr = nnef
              goto 220
           endif
  210   continue
  220   continue
        if (lelmnr /= 0) goto 9999
!
        do 230 inef = 1,elmndm
!
!----------compare local and global dimensions, not equal
!          => new error number and exit
!
           if (elmdim(inef)  /=  elt_dims(1+inef,lelmnr)) then
              error  = -15025
              goto 9999
           endif
  230   continue
      endif
      goto 10000
!
 9999 continue
      if (error  /=  0) then
         ierror = neferr(1, errstr)
        write(*,*) trim(errstr)
      endif
10000 continue
      ierror = clsnef( fd_nef )
!
      if ( timon ) call timstop ( ithndl )
      return
      end subroutine putget_real2D

!---------------------------------------------------------------------------
!     putget_char: specific procedure for reading/writing a CHARACTER
!---------------------------------------------------------------------------
      subroutine putget_char                                            &
                       (filnam    ,grpnam    ,nelems    ,elt_names  ,   &
                        elt_dims  ,elt_types ,elt_bytes ,elmnam     ,   &
                        celidt    ,wrilog    ,error     ,cbuffr     )
      implicit none
!
      integer(ip),dimension(:,:)               :: elt_dims
      integer(ip),dimension(:)                 :: elt_bytes
      integer(ip)                              :: celidt,nelems,error
!
      character(len=*)                         :: cbuffr
      character(len=len(cbuffr)),dimension(1)  :: buffr      ! array is placed on stack

      character(len=*),dimension(:)            :: elt_names,elt_types
      character(len=*)                         :: elmnam,filnam,grpnam
!
      logical                                  :: wrilog
!
      save       fd_nef
      integer :: fd_nef =  -1
      integer(4) ithndl              ! handle to time this subroutine
      data       ithndl / 0 /
      if ( timon ) call timstrt( "putget_char", ithndl )
!
      buffr(1) = cbuffr
!
!-----initialization
!
      coding        = 'n'
      elmndm        = 5
      do igr=1,no_groups
         usrord(igr)       = 1
         uindex(start,igr) = celidt
         uindex(stopp,igr) = celidt
         uindex(incr,igr)  = 1
      end do
!
!-----aggregate file names
!
      datnam = trim(filnam) // '.dat'
      call noextspaces(datnam,datlen)

      defnam = trim(filnam) // '.def'
      call noextspaces(defnam,deflen)
!
!-----write or read data from nefis files
!
      if (wrilog) then
        access = 'u'
      else
        access = 'r'
      endif
!
      error  = crenef (fd_nef, datnam(1:datlen), defnam(1:deflen),     &
                               coding, access)
      if (error /= 0 .and. .not.wrilog) then
        error = -211
        goto 9999
      endif
      if ( error /= 0 ) goto 9999

      if (wrilog) then
        error  = putels(fd_nef,grpnam,elmnam,  &
                        uindex,1     ,buffr        )
      else
        jnef=0
 123    continue
          jnef=jnef+1
          if (elmnam  ==  elt_names(jnef)) goto 124
          goto 123
 124    continue
        buflen = elt_bytes(jnef) ! size single precision integer
        do inef= 1, elt_dims(1,jnef)
          buflen = buflen*elt_dims(inef+1,jnef)
        enddo
        error  = getels(fd_nef,grpnam,elmnam,   &
                        uindex,usrord   ,buflen,buffr )
        if (error /= 0) goto 9999
      endif
!
!-----error:
!     writing: most likely error non existing group, so define it
!     reading: error, no error expected
!
      if ( error  /=  0 .and. wrilog ) then
! create elements
        do 110 lelmnr=1,nelems
          error  = defelm(fd_nef        ,elt_names(  lelmnr),    &
                          elt_types(lelmnr),elt_bytes(  lelmnr),    &
                          ' ' ,' ',                           &
                          ' ' ,elt_dims(1,lelmnr),              &
                          elt_dims(2,lelmnr)               )
!      most likely error, element already exist
          error = 0
  110   continue
! create cells
        error  = defcel(fd_nef,grpnam,nelems,elt_names)
        if ( error  /=  0 ) goto 9999
! create group on definition file
        error  = defgrp(fd_nef,grpnam,grpnam,1,0,1)
        if ( error  /=  0 ) goto 9999
! create group on data       file
        error  = credat(fd_nef,grpnam,grpnam)
        if ( error  /=  0 ) goto 9999
! try again to write data
        error  = putels(fd_nef,grpnam,elmnam, &
                        uindex,1     ,buffr        )
        if ( error  /=  0 ) goto 9999
      endif
!
!     no error when reading elements
!
      if (error == 0 .and. .not.wrilog) then
        error = inqelm(fd_nef,elmnam,elmtap,buflen,  &
                       elmqta,elmant,elmdas,elmndm,elmdim)

        if (error   /=  0) goto 9999
        lelmnr = 0
        do 210 nnef = 1,nelems
           if (elmnam  ==  elt_names(nnef)) then
              lelmnr = nnef
              goto 220
           endif
  210   continue
  220   continue
        if (lelmnr /= 0) goto 9999
!
        do 230 inef = 1,elmndm
!
!----------compare local and global dimensions, not equal
!          => new error number and exit
!
           if (elmdim(inef)  /=  elt_dims(1+inef,lelmnr)) then
              error  = -15025
              goto 9999
           endif
  230   continue
      endif
      goto 10000
!
 9999 continue
      if (error  /=  0) ierror = neferr(1, errstr)
10000 continue
      ierror = clsnef( fd_nef )
!
      if ( timon ) call timstop ( ithndl )
      return
      end subroutine putget_char

!---------------------------------------------------------------------------
!     putget_char1D: specific procedure for reading/writing a CHARACTER array
!---------------------------------------------------------------------------
      subroutine putget_char1D                                          &
                       (filnam    ,grpnam    ,nelems    ,elt_names  ,   &
                        elt_dims  ,elt_types ,elt_bytes ,elmnam     ,   &
                        celidt    ,wrilog    ,error     ,buffr     )
      implicit none
!
      integer(ip),dimension(:,:)    :: elt_dims
      integer(ip),dimension(:)      :: elt_bytes
      integer(ip)                   :: celidt,nelems,error
!
      character(len=*),dimension(:) :: buffr
      character(len=*),dimension(:) :: elt_names,elt_types
      character(len=*)              :: elmnam,filnam,grpnam
!
      logical                       :: wrilog
!
      save       fd_nef
      integer :: fd_nef =  -1
      integer(4) ithndl              ! handle to time this subroutine
      data       ithndl / 0 /
      if ( timon ) call timstrt( "putget_char1D", ithndl )
!
!-----initialization
!
      coding        = 'n'
      elmndm        = 5
      do igr=1,no_groups
         usrord(igr)       = 1
         uindex(start,igr) = celidt
         uindex(stopp,igr) = celidt
         uindex(incr,igr)  = 1
      end do
!
!-----aggregate file names
!
      datnam = trim(filnam) // '.dat'
      call noextspaces(datnam,datlen)

      defnam = trim(filnam) // '.def'
      call noextspaces(defnam,deflen)
!
!-----write or read data from nefis files
!
      if (wrilog) then
        access = 'u'
      else
        access = 'r'
      endif
!
      error  = crenef (fd_nef, datnam(1:datlen), defnam(1:deflen),     &
                               coding, access)
      if (error /= 0 .and. .not.wrilog) then
        error = -211
        goto 9999
      endif
      if ( error /= 0 ) goto 9999

      if (wrilog) then
        error  = putels(fd_nef,grpnam,elmnam,  &
                        uindex,1     ,buffr        )
      else
        jnef=0
 123    continue
          jnef=jnef+1
          if (elmnam  ==  elt_names(jnef)) goto 124
          goto 123
 124    continue
        buflen = elt_bytes(jnef) ! size single precision integer
        do inef= 1, elt_dims(1,jnef)
          buflen = buflen*elt_dims(inef+1,jnef)
        enddo
        error  = getels(fd_nef,grpnam,elmnam,   &
                        uindex,usrord  ,buflen,buffr )
        if (error /= 0) goto 9999
      endif
!
!-----error:
!     writing: most likely error non existing group, so define it
!     reading: error, no error expected
!
      if ( error  /=  0 .and. wrilog ) then
! create elements
        do 110 lelmnr=1,nelems
          error  = defelm(fd_nef        ,elt_names(  lelmnr),    &
                          elt_types(lelmnr),elt_bytes(  lelmnr),    &
                          ' ' ,' ',                           &
                          ' ' ,elt_dims(1,lelmnr),              &
                          elt_dims(2,lelmnr)               )
!      most likely error, element already exist
          error = 0
  110   continue
! create cells
        error  = defcel(fd_nef,grpnam,nelems,elt_names)
        if ( error  /=  0 ) goto 9999
! create group on definition file
        error  = defgrp(fd_nef,grpnam,grpnam,1,0,1)
        if ( error  /=  0 ) goto 9999
! create group on data       file
        error  = credat(fd_nef,grpnam,grpnam)
        if ( error  /=  0 ) goto 9999
! try again to write data
        error  = putels(fd_nef,grpnam,elmnam, &
                        uindex,1     ,buffr        )
        if ( error  /=  0 ) goto 9999
      endif
!
!     no error when reading elements
!
      if (error == 0 .and. .not.wrilog) then
        error = inqelm(fd_nef,elmnam,elmtap,buflen,  &
                       elmqta,elmant,elmdas,elmndm,elmdim)

        if (error   /=  0) goto 9999
        lelmnr = 0
        do 210 nnef = 1,nelems
           if (elmnam  ==  elt_names(nnef)) then
              lelmnr = nnef
              goto 220
           endif
  210   continue
  220   continue
        if (lelmnr /= 0) goto 9999
!
        do 230 inef = 1,elmndm
!
!----------compare local and global dimensions, not equal
!          => new error number and exit
!
           if (elmdim(inef)  /=  elt_dims(1+inef,lelmnr)) then
              error  = -15025
              goto 9999
           endif
  230   continue
      endif
      goto 10000
!
 9999 continue
      if (error  /=  0) ierror = neferr(1, errstr)
10000 continue
      ierror = clsnef( fd_nef )
!
      if ( timon ) call timstop ( ithndl )
      return
      end subroutine putget_char1D

end module putget_mod

max_stars_repo_name: liujiamingustc/phd

max_issues_repo_name: liujiamingustc/phd

max_forks_repo_name: liujiamingustc/phd


text:
      SUBROUTINE PIKLVL (*,LVLS1,LVLS2,CCSTOR,IDFLT,ISDIR,XC,NHIGH,
     1                   NLOW,NACUM,SIZE,STPT)
C
      INTEGER          CCSTOR(1), SIZE(1), STPT(1),  XC,  END, TEMP
      DIMENSION        NHIGH(1),  NLOW(1), NACUM(1), LVLS1(1), LVLS2(1)
      COMMON /BANDG /  IDUM,      IDPTH
C
C     THIS ROUTINE IS USED ONLY BY GIBSTK OF BANDIT MODULE
C
C     PIKLVL CHOOSES THE LEVEL STRUCTURE  USED IN NUMBERING GRAPH
C
C     LVLS1-    ON INPUT CONTAINS FORWARD LEVELING INFO
C     LVLS2-    ON INPUT CONTAINS REVERSE LEVELING INFO
C               ON OUTPUT THE FINAL LEVEL STRUCTURE CHOSEN
C     CCSTOR-   ON INPUT CONTAINS CONNECTED COMPONENT INFO
C     IDFLT-    ON INPUT =1 IF WDTH LVLS1'WDTH LVLS2, =2 OTHERWISE
C     NHIGH     KEEPS TRACK OF LEVEL WIDTHS FOR HIGH NUMBERING
C               DIMENSION OF NHIGH IS MAXIMUM ALLOWABLE NUMBER OF LEVELS
C     NLOW-     KEEPS TRACK OF LEVEL WIDTHS FOR LOW NUMBERING
C     NACUM-    KEEPS TRACK OF LEVEL WIDTHS FOR CHOSEN LEVEL STRUCTURE
C     XC-       NUMBER OF MAXIMUM ALLOWABLE CONNECTED COMPONENTS
C               (IS THE DIMENSION FOR SIZE AND STPT)
C     SIZE(I)-  SIZE OF ITH CONNECTED COMPONENT
C     STPT(I)-  INDEX INTO CCSTORE OF 1ST NODE IN ITH CON COMPT
C     ISDIR-    FLAG WHICH INDICATES WHICH WAY THE LARGEST CONNECTED
C               COMPONENT FELL.  =+1 IF LOW AND -1 IF HIGH
C
C
C     PART 1 -
C     ========
C     SORTS SIZE AND STPT HERE, IN DECENDING ORDER
C     (PREVIOUS SORT2 ROUTINE IS NOW MOVED INTO HERE.
C     THE ORIGINAL BUBBLE SORT HAS BEEN REPLACED BY THE MODIFIED SHELL
C     SORT WHICH IS MUCH FASTER   /G.CHAN,  MAY 1988)
C
      IF (XC .EQ. 0) RETURN 1
      M=XC
   10 M=M/2
      IF (M .EQ. 0) GO TO 70
      J=1
      K=XC-M
   20 I=J
   30 N=I+M
      IF (SIZE(N)-SIZE(I)) 60,60,50
   50 TEMP   =SIZE(I)
      SIZE(I)=SIZE(N)
      SIZE(N)=TEMP
      TEMP   =STPT(I)
      STPT(I)=STPT(N)
      STPT(N)=TEMP
      I=I-M
      IF (I .GE. 1) GO TO 30
   60 J=J+1
      IF (J-K) 20,20,10
   70 CONTINUE
C
C
C     PART 2 -
C     ========
C     CHOOSES THE LEVEL STRUCTURE USED IN NUMBERING GRAPH
C
C
C     FOR EACH CONNECTED COMPONENT DO
C
      DO 270 I=1,XC
      J  =STPT(I)
      END=SIZE(I)+J-1
C
C     SET NHIGH AND NLOW EQUAL TO NACUM
C
      DO 200 K=1,IDPTH
      NHIGH(K)=NACUM(K)
      NLOW(K) =NACUM(K)
  200 CONTINUE
C
C     UPDATE NHIGH AND NLOW FOR EACH NODE IN CONNECTED COMPONENT
C
      DO 210 K=J,END
      INODE=CCSTOR(K)
      LVLNH=LVLS1(INODE)
      NHIGH(LVLNH)=NHIGH(LVLNH)+1
      LVLNL=LVLS2(INODE)
      NLOW(LVLNL)=NLOW(LVLNL)+1
  210 CONTINUE
      MAX1=0
      MAX2=0
C
C     SET MAX1=LARGEST NEW NUMBER IN NHIGH
C     SET MAX2=LARGEST NEW NUMBER IN NLOW
C
      DO 220 K=1,IDPTH
      IF (2*NACUM(K).EQ.NLOW(K)+NHIGH(K)) GO TO 220
      IF (NHIGH(K).GT.MAX1) MAX1=NHIGH(K)
      IF (NLOW(K) .GT.MAX2) MAX2=NLOW(K)
  220 CONTINUE
C
C     SET IT= NUMBER OF LEVEL STRUCTURE TO BE USED
C
      IT=1
      IF (MAX1.GT.MAX2) IT=2
      IF (MAX1.EQ.MAX2) IT=IDFLT
      IF (IT.EQ.2) GO TO 250
      IF (I .EQ.1) ISDIR=-1
C
C     COPY LVLS1 INTO LVLS2 FOR EACH NODE IN CONNECTED COMPONENT
C
      DO 230 K=J,END
      INODE=CCSTOR(K)
      LVLS2(INODE)=LVLS1(INODE)
  230 CONTINUE
C
C     UPDATE NACUM TO BE THE SAME AS NHIGH
C
      DO 240 K=1,IDPTH
      NACUM(K)=NHIGH(K)
  240 CONTINUE
      GO TO 270
C
C     UPDATE NACUM TO BE THE SAME AS NLOW
C
  250 DO 260 K=1,IDPTH
      NACUM(K)=NLOW(K)
  260 CONTINUE
  270 CONTINUE
      RETURN
      END