      subroutine upscale(imsgin,xmsgin,cmsgin,msgtype,nwds,ierror)
C
C
C #####################################################################
C
C     PURPOSE -
C
C      Take a fine grid and upscale (interpolate) the attributes
C      of a fine grid (cmosrc) onto the course grid (cmo current).
C
C      The subroutine finds every node of the fine mesh within the
C      vornoi cell of every node in the course mesh.  Fine nodes on
C      cell boundaries are assigned to two or more course nodes.  Then the
C      attributes of all the fine cells within a course node's cell are
C      averaged.
C
C     SYNTAX -
C      NOTE:  the old command is
C      upscale/
C      avetype/attsink/1,0,0/cmosrc/attsrc
C      sink and source attributes assumed to be nnodes VDOUBLE
C      current MO assumed to be sink object
C
C
C      upscale /
C      scale_method/cmosink,attsink/1,0,0/cmosrc,attsrc/ [keepatt][set_id][method_options]
C
C      scale_method
C                ariave  - arithmatic average
C                      sink_val = (x(1) + x(i)... + x(n)) / n
C                      for 4 values; 1,2,3,4 ariave = 2.5
C                geoave  - geometric average
C                      sink_val = ( x(1) * x(i)... * x(n) )**(1/n)
C                      for 4 values; 1,2,3,4 geoave = 2.21336
C                harave  - harmonic average
C                      sink_val = n / ( 1/x(1) + 1/x(i)... + 1/x(n) )
C                      for 4 values; 1,2,3,4 harave = 1.92
C                sum - sum of source node attributes
C                      sink_val = x(1) + x(i)... + x(n)
C                      for 4 values; 1,2,3,4 sum = 10
C                min - choice of singl node attribute value
C                      sink_val = min(x(1),x(i),x(n))
C                      for 4 values; 1,2,3,4 min = 1
C                max - choice of singl node attribute value
C                      sink_val = max(x(1),x(i),x(n))
C                      for 4 values; 1,2,3,4 max = 4
C
C      KEEPATT   will keep added attributes and pt_gtg
C      set_id    will create source attribute pt_gtg and force a redo if exists
C
C      options for sum
C                - default, all nodes in Voronoi volume used
C                  regardless of nodes sharing Voronoi boundaries with others
C                - single, use node values once, then not again
C                  so that each Voronoi volume has single source sets
C                - divide, shared bndry values are detirmined and are
C                  divided by the number of voronoi volumes they occupy
C
C     EXAMPLE:
C       cmo / select / cmoquad
C       upscale/ ariave / xval /1,0,0/ cmopt s/ tval
C
C       This will compute arithmatic average on tval for all
C       nodes from CMO cmopt that are within each vornoi cell in
C       CMO cmoquad.
C       Values will be written to attribute xval in cmoquad.
C
C     INPUT ARGUMENTS -
C
C        imsgin()  - Integer array of command input tokens
C        xmsgin()  - Real array of command input tokens
C        cmsgin()  - Character array of command input tokens
C        msgtype() - Integer array of command input token types
C        nwds      - Number of command input tokens
C
C     OUTPUT ARGUMENTS -
C
C        ierror - Error Return Code (==0 ==> OK, <>0 ==> Error)
C
C     CHANGE HISTORY -
C $Log: upscale.f,v $
C Revision 2.00  2007/11/09 20:04:05  spchu
C Import to CVS
C
CPVCS
CPVCS       Rev 1.5   18 Jun 2007 07:18:02   tam
CPVCS    better logic regarding search and keepatt option
CPVCS    better reporting regarding setup and options
CPVCS
CPVCS       Rev 1.4   13 Jun 2007 07:13:10   tam
CPVCS    new version adds options sum, min, and max
CPVCS    syntax and code updated to mirror interpolate
CPVCS    debug and error checking added
CPVCS    option single added to conserve number of nodes used
CPVCS    so nodes sharing voronoi boundaries are used only once
CPVCS    this version is runs fine on test, but needs more work
CPVCS
CPVCS       Rev 1.3   Thu Apr 06 14:28:24 2000   dcg
CPVCS    replace get_info_i calls
CPVCS
CPVCS       Rev 1.2   Tue Sep 22 13:45:36 1998   dcg
CPVCS    replace single precision constants
CPVCS
CPVCS       Rev 1.1   Fri Jun 20 16:01:36 1997   dcg
CPVCS    separate out kdtree0 and nearestpoint0
C
C
C ######################################################################
C
      implicit none

      integer nplen, ntlen
      parameter (nplen=1000000)
      parameter (ntlen=1000000)
C
C#######################################################################
C
      integer nwds, imsgin(nwds), msgtype(nwds)
      real*8 xmsgin(nwds)
      character*(*) cmsgin(nwds)
C
      integer ierror
C
C#######################################################################
C
      character*132 logmess, cbuff
C
      pointer (ipxic, xic)
      pointer (ipyic, yic)
      pointer (ipzic, zic)
      real*8  xic(nplen), yic(nplen), zic(nplen)
C
      character*32 ich1,ich2,ich3
      character*32 isubname
      character*32 intrp_opt, sum_opt, keep_opt, set_opt
      character*32  blkname, cmosnk, cmosrc
      character*32  attsnk, attsrc, cpers, cio
      character*32  crank_snk,cinter_snk,ctype_snk,clen_snk
      character*32  crank_src,cinter_src,ctype_src,clen_src
      character*132 cbuf
      real*8 alargenumber
      data alargenumber/1.d99/
C
C     xfield (ifield) is source, xout (iout) is sink
C     ptmp is for checking attributes
C     xsource is for assiging mmgetblk to VINT or VDOUBLE
      pointer(iptmp, ptmp)
      pointer(ipxout, xout)
      pointer(ipxfield, xfield)
      pointer(ipxsource, xsource)
      real*8 ptmp(nplen),xout(nplen),xfield(nplen),xsource(nplen)

C     integer pointers for VINT attributes
      pointer(ipiout, iout)
      pointer(ipifield, ifield)
      integer iout(nplen), ifield(nplen)

C     may not need element pointers
      pointer (ipitettyp, itettyp)
      pointer (ipitet, itet)
      pointer (ipitetoff, itetoff)
      integer itettyp(nplen),itet(nplen),itetoff(nplen)

C     value and vor_bndry are accumulated for sink
      pointer (ipvalue, value)
      pointer (ipvor_bndry, vor_bndry)
      real*8 value(nplen),vor_bndry(nplen)
C
      pointer (ipxic_src, xic_src)
      pointer (ipyic_src, yic_src)
      pointer (ipzic_src, zic_src)
      real*8  xic_src(nplen), yic_src(nplen), zic_src(nplen)

      pointer (ipisetwd, isetwd)
      pointer (ipitp1, itp1)
      integer isetwd(nplen), itp1(nplen)

      pointer (ipdistpossleaf, distpossleaf)
      real*8 distpossleaf(nplen)

      pointer (ipnneigh, nneigh)
      pointer(ipmpary, mpary)
      pointer (ipsbox, sbox)
      pointer (iplinkt, linkt)
      pointer (ipitfound, itfound)
      integer nneigh(nplen),mpary(nplen),
     * sbox(nplen),linkt(nplen),itfound(nplen)

C     counters for source nodes in sink voronoi volumes
      pointer (ipnnum, nnum)
      pointer (ipndups, ndups)
      pointer (ipnbndry, nbndry)
      integer nnum(nplen),ndups(nplen),nbndry(nplen)

C     optional SOURCE mesh object attributes
C     pt_gtg has assigned node id
C     dups_gtg are in duplicate Voronoi boundaries
      pointer (ippt_gtg, pt_gtg)
      pointer (ipdups_gtg, dups_gtg)
      integer  pt_gtg(nplen), dups_gtg(nplen)

      integer iisrc,ntets,iisnk, ikeep, set_id,
     * nsdtopo, nsdgeom, nsdtopo_src, nsdgeom_src,
     * length, length_snk, length_src,
     * npoints, npoints_src, nwd_pset,
     * nen_src,nef_src

      integer ipt,iwrite,nwrite,iperc,totsrchd,totfind,istep,
     * totflag,idone,idebug,icntsink,icntsrc,mbndry,idx,
     * ndups_tot,ipt_exist,idups_exist,if_search,mk_ptatt

      integer j,i,ii,iff,ipt1,ipt2,ipt3,mpno,len,
     * ipointi,ipointj,ilen,ityp, mtfound,inxt,
     * ics,ics2,ics3, ierr,ierrw,ntype,icmotype

      integer bndrypt,bndryid,ipt_gtg,idups_gtg

      integer icharlnf

      real*8 xperc, maxval,minval,testval
      real*8 xq,yq,zq,xs,ys,zs,eps
C     real*8 xdist,ydist,zdist,dis,dmin

C
C#######################################################################
C
C
C
      isubname='upscale'
C
      ierror = 0
      idebug=0
      ndups_tot=0
      keep_opt = "delatt"
      sum_opt = "multiple"
      set_opt = "set_id"
      set_id = 0
      mk_ptatt = 1
      if_search = 1
      ikeep = 0
C
C     ******************************************************************
C     PARSE ARGUMENTS
C     scale_method/cmosnk,attsink/1,0,0/cmosrc,attsrc/ [keepatt] [method_options]
C            2      3       4     5 6  7     8     9
C     intrp_opt/attsink     /i j k    /cmosrc/attsrc

C     BAD SYNTAX
      if (nwds.lt.7) then
        write(logmess,'(a)')
     *   'UPSCALE/scale_opt/cmosnk,attsink/1,0,0/cmosrc,attsrc'
        call writloga('default',0,logmess,1,ierrw)
        ierror = -1
        goto 9999

C     OLD SYNTAX uses current mesh object as sink
      elseif (nwds.le.8) then
        call cmo_get_name(cmosnk,ierror)
        if(ierror.ne.0) then
          write(logmess,'(a)') 'Current mesh object not found.'
          call writloga('default',0,logmess,0,ierrw)
          goto 9999
        endif
        intrp_opt=cmsgin(2)
        attsnk=cmsgin(3)
        cmosrc=cmsgin(7)(1:icharlnf(cmsgin(7)))
        if(nwds.lt.8) then
           attsrc=attsnk
        else
           attsrc=cmsgin(8)(1:icharlnf(cmsgin(8)))
        endif
        nwd_pset=4
      else

C     NEW SYNTAX similar to interoplate
        intrp_opt=cmsgin(2)
        cmosnk=cmsgin(3)
        attsnk=cmsgin(4)
        nwd_pset=5
        cmosrc=cmsgin(8)(1:icharlnf(cmsgin(8)))
        attsrc=cmsgin(9)(1:icharlnf(cmsgin(9)))

C     Loop through remaining optional command tokens
C     The first 9 are neccessary, the remainder are not
C     token ordering for remainder is ignored
C     i increments through each of the remainder tokens
C     inxt increments past i if a token is paired with a value
C       keepatt - attributes not deleted
C       set_id
C       sum_opt = single, divide, none

      inxt = 10
      do i = 10,nwds
        inxt = max(i,inxt)
        if(msgtype(inxt).eq.3) then
          if((cmsgin(inxt)(1:4).eq.'keep') .or.
     *      (cmsgin(inxt)(1:4).eq.'KEEP')) then
            ikeep = 1
            keep_opt="keepatt"
            inxt=inxt+1
          elseif((cmsgin(inxt)(1:6).eq.'delatt') .or.
     *      (cmsgin(inxt)(1:6).eq.'DELATT')) then
            ikeep = 0
            keep_opt="delatt"
            inxt=inxt+1
          elseif((cmsgin(inxt)(1:6).eq.'single') .or.
     *      (cmsgin(inxt)(1:6).eq.'SINGLE')) then
            sum_opt = 'single'
            inxt=inxt+1
          elseif((cmsgin(inxt)(1:6).eq.'divide') .or.
     *      (cmsgin(inxt)(1:6).eq.'DIVIDE')) then
C           NOT IMPLEMENTED YET
C           sum_opt = 'divide'
            sum_opt = 'none'
            inxt = inxt+1
          elseif((cmsgin(inxt)(1:6).eq.'set_id') .or.
     *           (cmsgin(inxt)(1:6).eq.'SET_ID')) then
            set_id = 1
            set_opt="set_id"
            inxt=inxt+1
          endif
        endif
      enddo
      if (ikeep.eq.1 .and. set_id.eq.0) set_opt="  "
      endif
C     End command processing - Done with message arrays

C     Check the mesh object names
      call cmo_exist(cmosnk,ierr)
      if(ierr.ne.0) then
         write(logmess,'(a,a)')
     *     'UPSCALE: Not a valid mesh object: ',cmosnk
         call writloga('default',1,logmess,1,ierrw)
         goto 9000
      endif

      call cmo_exist(cmosrc,ics)
      if(ics.ne.0) then
         write(logmess,'(a,a)')
     *   'UPSCALE: Not a valid mesh object: ',cmosrc
         call writloga('default',1,logmess,1,ierrw)
         goto 9000
      endif

C     Check mesh object attributes with temporary pointer iptmp
      len=icharlnf(attsrc)
      if(len.eq.3) then
        if(attsrc(1:3).eq.'itp') attsrc='itp1'
        if(attsrc(1:3).eq.'imt') attsrc='imt1'
        if(attsrc(1:3).eq.'icr') attsrc='icr1'
        if(attsrc(1:3).eq.'isn') attsrc='isn1'
      endif
      len=icharlnf(attsnk)
      if(len.eq.3) then
        if(attsnk(1:3).eq.'itp') attsnk='itp1'
        if(attsnk(1:3).eq.'imt') attsnk='imt1'
        if(attsnk(1:3).eq.'icr') attsnk='icr1'
        if(attsnk(1:3).eq.'isn') attsnk='isn1'
      endif
      call mmfindbk(attsrc,cmosrc,iptmp,ilen,ierr)
      if(ierr.ne.0) then
         write(logmess,'(a,a,a,a,a)') 'attribute does not exist: ',
     *      '  cmo= ',cmosrc(1:icharlnf(cmosrc)),
     *      '  att= ',attsrc(1:icharlnf(attsrc))
         call writloga('default',0,logmess,0,ierrw)

         call mmfindbk(attsnk,cmosnk,iptmp,ilen,ics)
         if(ics.ne.0) then
           write(logmess,'(a,a,a,a,a)') 'attribute does not exist: ',
     *        '  cmo= ',cmosnk(1:icharlnf(cmosnk)),
     *        '  att= ',attsnk(1:icharlnf(attsnk))
           call writloga('default',0,logmess,0,ierrw)
         endif
         if (ierr.ne.0 .or. ics.ne.0) goto 9000
      endif

C     DETERMINE SCALE METHOD TYPE
      ntype=0
      if (intrp_opt(1:6).eq.'harave') then
         ntype=1
      elseif (intrp_opt(1:6).eq.'ariave') then
         ntype=2
      elseif (intrp_opt(1:6).eq.'geoave') then
         ntype=3
      elseif (intrp_opt(1:3).eq.'sum') then
         ntype=4
      elseif (intrp_opt(1:3).eq.'max') then
         ntype=5
      elseif (intrp_opt(1:3).eq.'min') then
         ntype=6
      endif

      if (ntype.eq.0) then
         ierror=1
         write(logmess,6000) intrp_opt
 6000    format('  ERROR - INVALID UPSCALE TYPE ',a8)
         call writloga('default',0,logmess,0,ierrw)
         go to 9999
      endif

C     ******************************************************************
C     GET INFO COARSE SINK CMO and ATTRIBUTE

      call cmo_select(cmosnk,ierr)
      call cmo_get_intinfo('nnodes',cmosnk,npoints,ilen,ityp,ierr)
      if(ierr.ne.0) call x3d_error(isubname,'intinfo nnodes cmosink')
      call cmo_get_intinfo('nelements',cmosnk,ntets,ilen,ityp,ierr)
      if(ierr.ne.0) call x3d_error(isubname,'intinfo nelements cmosink')
      length_snk = npoints
      if (ierr.ne.0) goto 9000

      call cmo_get_info('idebug',cmosnk,idebug,len,ityp,ierr)

      call cmo_get_intinfo('mbndry',cmosnk,mbndry,ilen,ityp,ierr)
      if(ierr.ne.0) call x3d_error(isubname,'intinfo mbndry cmosink')
      if (ierr.ne.0) goto 9000
      call cmo_get_intinfo('ndimensions_geom',cmosnk,
     *                      nsdgeom,ilen,ityp,ierr)
      call cmo_get_intinfo('ndimensions_topo',cmosnk,
     *                      nsdtopo,ilen,ityp,ierr)

      call cmo_get_info('xic',cmosnk,ipxic,ilen,ityp,ierr)
      call cmo_get_info('yic',cmosnk,ipyic,ilen,ityp,ierr)
      call cmo_get_info('zic',cmosnk,ipzic,ilen,ityp,ierr)
      if(ierr.ne.0) call x3d_error(isubname,'get_info xyz cmosink')
      call cmo_get_info('itettyp',cmosnk,ipitettyp,ilen,ityp,ierr)
      call cmo_get_info('itetoff',cmosnk,ipitetoff,ilen,ityp,ierr)
      call cmo_get_info('itet',cmosnk,ipitet,ilen,ityp,ierr)
      if(ierr.ne.0) call x3d_error(isubname,'get_info itet cmosink')
      if (ierr.ne.0) goto 9000

      call cmo_get_info('isetwd',cmosnk,ipisetwd,ilen,ityp,ierr)
      if(ierr.ne.0) call x3d_error(isubname,'get_info isetwd cmosink')
      call cmo_get_info('itp1',cmosnk,ipitp1,ilen,ityp,ierr)
      if(ierr.ne.0) call x3d_error(isubname,'get_info itp1 cmosink')
      if (ierr.ne.0) goto 9000

      call cmo_get_info('ipointi',cmosnk,ipointi,ilen,ityp,ierr)
      if (ierr .ne. 0) call x3d_error(isubname,'ipointi cmosink')
      call cmo_get_info('ipointj',cmosnk,ipointj,ilen,ityp,ierr)
      if (ierr .ne. 0) call x3d_error(isubname,'ipointj cmosink')
      if (ierr.ne.0) goto 9000
C
      if(ipointj.eq.0) ipointj=npoints
      if(ipointj.gt.npoints) ipointj=npoints

c     Get sink attribute info and assign attribute length
      call cmo_get_attparam(attsnk,cmosnk,idx,ctype_snk,crank_snk,
     *    clen_snk,cinter_snk,cpers,cio,ierr)
      if(ierr.ne.0) call x3d_error(isubname,'get_attparam sink')

C     Assign sink attribute to xout or iout array
C     INT attribute will be converted and copied to xout
      length=npoints
      len=icharlnf(attsnk)
      blkname=' '
      blkname(1:len)=attsnk
      if(ctype_snk(1:4).eq.'VINT') then
        call mmgetpr(blkname,cmosnk,ipiout,ics)
        call mmgetlen(ipiout,length_snk,ics2)
        if(ics.ne.0 .or. ics2.ne.0) then
          call x3d_error(isubname,'mmgetpr sink attribute')
          goto 9000
        endif
      elseif(ctype_snk(1:7).eq.'VDOUBLE') then
        call mmgetpr(blkname,cmosnk,ipxout,ics)
        call mmgetlen(ipxout,length_snk,ics2)
        if(ics.ne.0 .or. ics2.ne.0) then
          call x3d_error(isubname,'mmgetpr sink attribute')
          goto 9000
        endif
      else
        write(logmess,'(a,a,a,a)')
     *  'Invalid attribute type for ',cmosnk(1:icharlnf(cmosnk)),
     *   ' ',blkname(1:len)
         call writloga('default',1,logmess,0,ierrw)
         goto 9000
      endif

C
C     ******************************************************************
C     set the point index boundaries for sink points
      length=length_snk
      ich1=' '
      ich2=' '
      ich3=' '
      mpno=0
      if(msgtype(nwd_pset).eq.1) then
         ipt1=imsgin(nwd_pset)
         ipt2=imsgin(nwd_pset+1)
         ipt3=imsgin(nwd_pset+2)
      else
         ich1=cmsgin(nwd_pset)
         ich2=cmsgin(nwd_pset+1)
         ich3=cmsgin(nwd_pset+2)
      endif

c     For node point set
      length=npoints
      call mmgetblk('mpary',isubname,ipmpary,length,2,ics)
      if(ics.ne.0) call x3d_error(isubname,'mmgetblk mpary')
      if (ics.ne.0) goto 9000

      if(msgtype(nwd_pset).eq.1) then
         call pntlimn(ipt1,ipt2,ipt3,ipmpary,mpno,ipointj,isetwd,itp1)
      else
         call pntlimc(ich1,ich2,ich3,ipmpary,mpno,ipointj,isetwd,itp1)
      endif
      if (mpno.ne.0) then
        if (mpno.ne.npoints) then
           write(logmess,'(a,i10)')
     *      'nodes in selected point set  = ',mpno
           call writloga('default',0,logmess,0,ierrw)
         endif
      else
           write(logmess,'(a)') 'No points in selected point set!'
           call writloga('default',1,logmess,1,ierrw)
           goto 9000
      endif

C     ******************************************************************
C     GET INFO FINE SOURCE CMO and ATTRIBUTE
C
      call cmo_select(cmosrc,ierr)
      call cmo_get_intinfo('nnodes',cmosrc,npoints_src,ilen,ityp,ierr)
      if(ierr.ne.0) call x3d_error(isubname,'intinfo nnodes cmosource')
      call cmo_get_intinfo('ndimensions_geom',cmosrc,
     *                      nsdgeom_src,ilen,ityp,ierr)
      call cmo_get_intinfo('ndimensions_topo',cmosrc,
     *                      nsdtopo_src,ilen,ityp,ierr)
      if (ierr.ne.0) goto 9000

      call cmo_get_info('xic',cmosrc,ipxic_src,ilen,ityp,ierr)
      call cmo_get_info('yic',cmosrc,ipyic_src,ilen,ityp,ierr)
      call cmo_get_info('zic',cmosrc,ipzic_src,ilen,ityp,ierr)
      if(ierr.ne.0) call x3d_error(isubname,'get_info xyz cmosource')
      if (ierr.ne.0) goto 9000

c     get source attribute info and assign attribute length
      call cmo_get_attparam(attsrc,cmosrc,idx,ctype_src,crank_src,
     *    clen_src,cinter_src,cpers,cio,ierr)
      if(ierr.ne.0) call x3d_error(isubname,'get_attparam source')
      if (ierr.ne.0) goto 9000
      if (clen_src(1:5).eq.'nnode') then
         length_src = npoints_src
      else
        write(logmess,'(a)')"Error: Source cmo must use node attribute."
        call writloga('default',0,logmess,0,ierrw)
        goto 9000
      endif

C     Assign source attribute to xfield or ifield array
C     INT attribute will be converted and copied to xfield
      length=npoints_src
      len=icharlnf(attsrc)
      blkname=' '
      blkname(1:len)=attsrc
      if(len.eq.3) then
        if(blkname(1:3).eq.'itp') blkname='itp1'
        if(blkname(1:3).eq.'imt') blkname='imt1'
        if(blkname(1:3).eq.'icr') blkname='icr1'
        if(blkname(1:3).eq.'isn') blkname='isn1'
        len=icharlnf(blkname)
      endif
      if(ctype_src(1:4).eq.'VINT') then
        call mmgetpr(blkname,cmosrc,ipifield,ics)
        call mmgetlen(ipifield,length_src,ics2)
        call mmgetblk('xsource',isubname,ipxsource,length,2,ics)
        if(ics.ne.0) call x3d_error(isubname,'mmgetblk xsource')
        ipxfield = ipxsource
      elseif(ctype_src(1:7).eq.'VDOUBLE') then
        call mmgetpr(blkname,cmosrc,ipxfield,ics)
        call mmgetlen(ipxfield,length_src,ics2)
        if(ics.ne.0) call x3d_error(isubname,'mmgetpr xfield')
      else
        write(logmess,'(a,a,a,a)')
     *  'Invalid attribute type for ',cmosrc(1:icharlnf(cmosrc)),
     *   ' ',blkname(1:len)
         call writloga('default',1,logmess,0,ierrw)
         goto 9000
      endif
      if (ics.ne.0) goto 9000

C     check to see if the two cmo's have the same geometric dimension
C     old code stopped here, allow to continue
      if( nsdgeom .ne. nsdgeom_src) then
         write(logmess,'(a)')"WARNING: cmo's need same dimension"
         call writloga('default',0,logmess,0,ierrw)
      endif

C     ******************************************************************
C     WORK ARRAYS

C        allocate SINK work arrays
         ilen=npoints
         call mmgetblk('value',isubname,ipvalue,ilen,2,ics2)
         call mmgetblk('nnum',isubname,ipnnum ,ilen,1,ics)
         if(ics.ne.0 .or. ics2.ne.0) then
            call x3d_error(isubname,'mmgetblk work arrays for sink')
            goto 9000
         endif

C        special arrays for sum
         call mmgetblk('vor_bndry',isubname,ipvor_bndry,ilen,2,ics)
         call mmgetblk('ndups',isubname,ipndups ,ilen,1,ics2)
         call mmgetblk('nbndry',isubname,ipnbndry ,ilen,1,ics3)
         if(ics.ne.0 .or. ics2.ne.0 .or. ics3.ne.0) then
            call x3d_error(isubname,'mmgetblk work arrays for sum')
            goto 9000
         endif

C        TAM - nneigh not being used
C        allocate SOURCE work arrays
C        length=npoints_src
C        call mmgetblk('nneigh',isubname,ipnneigh,length,1,ics)
C        if(ics.ne.0 ) then
C           call x3d_error(isubname,'mmgetblk work arrays for nneigh')
C           goto 9000
C        endif

C     ******************************************************************
C     add attributes to SOURCE cmo to track nodes used for sink Voronoi
C     pt_gtg fills source points with corresponding sink node id
C     dups_gtg tags nodes in multiple sink Voronoi volumes

C     pt_gtg will use kdtree search loop to fill source points with
C     associated sink node points
C     Note, this is a one-to-one correlation and does not handle
C     duplicate nodes in shared Voronoi volumes
      call mmgetpr('pt_gtg',cmosrc,ippt_gtg,ipt_exist)
      if (ipt_exist.eq.0) then
        call cmo_get_info('pt_gtg',cmosrc,ippt_gtg,ilen,ityp,ics)
        if(ics.ne.0) then
          write(logmess,'(a,a,a,a)')
     *    'upscale attribute does not exist: ',
     *    '  cmo= ',cmosrc(1:icharlnf(cmosrc)),'  att= pt_gtg '
          call writloga('default',1,logmess,1,ierrw)
          goto 9000
        endif
        if_search = 0
        ipt_exist = 1
      else
        if_search = 1
        ipt_exist = 0
      endif
C     force removal of pt_gtg and fill again
      if (ipt_exist.eq.1 .and. set_id.eq.1) then
        len=icharlnf(cmosrc)
        cbuff = 'cmo DELATT '//cmosrc(1:len)//'/pt_gtg ;  finish'
        call dotaskx3d(cbuff,ierr)
        ipt_exist=0
      endif

C     These are flagged counts for duplicate nodes on cell boundaries
C     if set_id, force removal of dups_gtg and fill again
      call mmgetpr('dups_gtg',cmosrc,ipdups_gtg,idups_exist)
      if (idups_exist.eq.0) then
        call cmo_get_info('dups_gtg',cmosrc,ipdups_gtg,ilen,ityp,ics)
        if(ics.ne.0) then
          write(logmess,'(a,a,a,a)')
     *    'upscale attribute does not exist: ',
     *    '  cmo= ',cmosrc(1:icharlnf(cmosrc)),'  att= dups_gtg '
          call writloga('default',1,logmess,1,ierrw)
          goto 9000
        endif
        idups_exist = 1
      else
        idups_exist = 0
      endif
C     force removal of dups_gtg and fill again
      if (idups_exist.eq.1 .and. set_id.eq.1) then
        len=icharlnf(cmosrc)
        cbuff = 'cmo DELATT '//cmosrc(1:len)//'/dups_gtg ;  finish'
        call dotaskx3d(cbuff,ierr)
        idups_exist=0
      endif

C     add attributes if not exist
      if (ipt_exist.eq.0) then
        cbuff = 'cmo/addatt/'//cmosrc(1:icharlnf(cmosrc))//
     *  '/pt_gtg/' //
     *  'VINT/scalar/nnodes//permanent/agfx/0 ; finish'
        call dotaskx3d(cbuff,ierr)
        if(ierr.ne.0) then
          call x3d_error(isubname,'make att pt_gtg')
          goto 9000
        endif
        call mmgetpr('pt_gtg',cmosrc,ippt_gtg,ics)
        ipt_exist = 1
        if_search = 1
      endif
      if (idups_exist.eq.0) then
        cbuff = 'cmo/addatt/'//cmosrc(1:icharlnf(cmosrc))//
     *  '/dups_gtg/' //
     *  'VINT/scalar/nnodes//permanent/agfx/0 ; finish'
        call dotaskx3d(cbuff,ierr)
        if(ierr.ne.0) then
          call x3d_error(isubname,'make att dups_gtg')
          goto 9000
        endif
        call mmgetpr('dups_gtg',cmosrc,ipdups_gtg,ics)
        idups_exist = 1
      endif

C     report attribute status for source cmo being kept and set
      if (ikeep.eq.1 .and. if_search.eq.1) then
        write(logmess,'(a)')
     * 'pt_gtg attribute added to source cmo.'
        call writloga('default',0,logmess,0,ierrw)
        write(logmess,'(a)')
     * 'nodes on Voronoi boundaries used by multiple volumes.'
        call writloga('default',0,logmess,0,ierrw)
        write(logmess,'(a)')
     * 'dups_gtg attribute added to source cmo.'
        call writloga('default',0,logmess,0,ierrw)
      endif

C     report attribute status for source cmo being kept and already set
      if (ikeep.eq.1 .and. if_search.eq.0) then
        sum_opt = 'single'
        write(logmess,'(a)')
     * 'nodes on Voronoi boundaries set to a single source volume.'
        call writloga('default',0,logmess,0,ierrw)
        write(logmess,'(a)')
     * 'pt_gtg being used for sink node id numbers.'
        call writloga('default',0,logmess,0,ierrw)
        write(logmess,'(a)')
     * 'dups_gtg being used for nodes on duplicate cell boundaries.'
        call writloga('default',0,logmess,0,ierrw)
      endif

C     GET POINTERS for added attributes
      call cmo_get_info('pt_gtg',cmosrc,ippt_gtg,ilen,ityp,ierr)
      if (ierr.ne.0) then
        write(logmess,"(a,a)")
     * 'WARNING: could not addatt pt_gtg for ',cmosrc
        call writloga('default',0,logmess,0,ierrw)
        ipt_exist=0
      else
        ipt_exist=1
      endif
      call cmo_get_info('dups_gtg',cmosrc,ipdups_gtg,ilen,ityp,ierr)
      if (ierr.ne.0) then
        write(logmess,"(a,a)")
     * 'WARNING: could not addatt dups_gtg for ',cmosrc
        call writloga('default',0,logmess,0,ierrw)
        idups_exist=0
      else
        idups_exist=1
      endif

C     ******************************************************************
c     If source attribute is INT, convert and copy into xfield
      if(ctype_src(1:4).eq.'VINT') then
         do i=1,length_src
            xfield(i) = dble(ifield(i))
         enddo
      endif

C     ******************************************************************
C     Done with setup and error checking, start work for upscale
c     Write summary of interpolation setup and type

      write(logmess,'(a,a10,a,a10)')
     * 'UPSCALE METHOD: ',intrp_opt(1:icharlnf(intrp_opt))
      call writloga('default',1,logmess,0,ierrw)

      write(logmess,'(a, a10,a10,a10)')
     * '       options: ',keep_opt(1:icharlnf(keep_opt)),
     *  sum_opt(1:icharlnf(sum_opt)),
     *  set_opt(1:icharlnf(set_opt))
      call writloga('default',0,logmess,0,ierrw)

      write(logmess,'(2x,i10,a,a,a,a)')
     * npoints,'  Sink Nodes of ',attsnk(1:icharlnf(attsnk)),
     * ' in course mesh: ',cmosnk(1:icharlnf(cmosnk))
      call writloga('default',0,logmess,0,ierrw)
      if (mpno.ne.npoints) then
        write(logmess,'(2x,i10,a)')
     *   mpno,' Selected Set of Nodes will be written '
      call writloga('default',0,logmess,0,ierrw)
      endif

      write(logmess,'(2x,i10,a,a,a,a)')
     * npoints_src,'  Source Nodes of ',attsrc(1:icharlnf(attsrc)),
     * ' in fine mesh: ',cmosrc(1:icharlnf(cmosrc))
      call writloga('default',0,logmess,0,ierrw)

C     ******************************************************************
C     INITIALIZE WORK ARRAYS and VARIABLES
       length=5*npoints_src
       call mmgetblk('itfound',isubname,ipitfound,length,1,ics)
       if(ics.ne.0 ) call x3d_error(isubname,' get itfound')

C  move these into loop where pt_gtg may be used instead
C      length=12*npoints
C      call mmgetblk('sbox',isubname,ipsbox,length,2,ics)
C      length=2*npoints
C      call mmgetblk('linkt',isubname,iplinkt,length,1,ics)

c      initialize work arrays for sink
       do ii=1,npoints
         value(ii)=0.
         nnum(ii)=0
       enddo

c      variables for progress reporting
       iwrite=0
       ipt=0
       istep=1
       totsrchd = 0
       totfind = 0
       totflag = 0
       if ( max(npoints,npoints_src) .gt. 500000 ) then
         xperc = 50.
         iperc = 2
       elseif ( max(npoints,npoints_src) .gt. 10000 ) then
         xperc = 20.
         iperc = 5
       else
         xperc = 4.
         iperc = 25
       endif
       nwrite=nint(dble(npoints_src)/ xperc )

C     ******************************************************************
C     SEARCH FOR NEAREST SOURCE NODES
C .... Use A. kuprat's kdtree routines here instead of local search (below)
C
c      fill coordinates with current point
c      TAM note: do we really want to assign zs by checking nsdgeom?
C     Build the search tree for nearest points

c       Build kdtree to search for nearest source points
        if (if_search.eq.0) then
          write(logmess,"(a)")
     *    'SKIPPING POINT SEARCH... using lookup attribute pt_gtg'
          call writloga('default',0,logmess,0,ierrw)

        else
          length=12*npoints
          call mmgetblk('sbox',isubname,ipsbox,length,2,ierr)
          length=2*npoints
          call mmgetblk('linkt',isubname,iplinkt,length,1,ics)
          if(ierr.ne.0 .or. ics.ne.0)
     *       call x3d_error(isubname,' get linkt and sbox')
          call kdtree0(xic,yic,zic,npoints,linkt,sbox,ierr)
          if(ierr.ne.0 ) call x3d_error(isubname,' kdtree0 ')
          eps=-1.
          mtfound=0
          xs=alargenumber
          ys=alargenumber
          zs=0.
          if(nsdgeom_src.eq.3) zs=alargenumber
        endif

C#######################################################################
C         INTEROPLATE FOUND NODES ON TO THE SOURCE MESH NODES
C         ntype
C         1 harave  - harmonic average
C         2 ariave  - arithmatic average
C         3 geoave  - geometric average
C         4 sum     - sum the values
C         5 max     - assign max value
C         6 min     - assign min value
C
C      FOR EACH SOURCE NODE
C           LOOP THROUGH SINK POINTS
C           COMPUTE NODES FOR FOUND VORONOI VOLUME
C
       length=npoints
       call mmgetblk('distpossleaf',isubname,ipdistpossleaf,
     * length,2,ierr)

       icntsrc = 0
       iisnk=0
       do ii=1,npoints_src
            if(if_search.eq.1) pt_gtg(ii)=-1
            if(if_search.eq.1) dups_gtg(ii)=0
            ipt=ii
            xq=xic_src(ii)
            yq=yic_src(ii)
            zq=zic_src(ii)

C          Find points within Voronoi volume of sink point
c          xs,ys,zs  - spatial coordinates of PREVIOUS nearest point
c          eps  -    epsilon for length comparisons
c          mtfound - number of points  returned
c          itfound - array of found points
c          linkt,sbox -   k-D tree arrays

c          Get nearest point number iisnk from attribute pt_gtg
           if(if_search.eq.0) then
              iisnk=pt_gtg(ipt)
              if(iisnk.gt.0) then
                mtfound = 1
                itfound(1) = iisnk
              else
                mtfound = -1
              endif
           else

             call nearestpoint0(xq,yq,zq,xs,ys,zs,linkt,sbox,eps,
     *       npoints,distpossleaf,mtfound,itfound,ierr)

           if(ierr.ne.0 ) call x3d_error(isubname,' nearestpoint0')

           endif
           if (mtfound.gt.0) then
              totfind=totfind+mtfound
           else
              totflag=totflag+1
           endif

C           FOR EACH SOURCE NODE FOUND
C                LOOP THROUGH SINK POINTS WITHIN VORONOI VOLUME
c           do the various types of averaging
c           ......iisnk is node id in the course sink mesh
c           ..... iisrc is node id in the source fine mesh
c           ..... nnum(iisnk) count of source points for each sink point
c           ..... value(iisnk) holds calculated value so far
c           ..... xfield(iisrc) is the source attribute
c           ..... dups_gtg(iisrc) counts duplicate Voronoi source nodes

            do iff=1,mtfound
              iisnk=itfound(iff)
              iisrc=ii

C             IF SEARCH IS TRUE
C             keep track of source nodes used for each sink node
C             count source nodes in multiple Voronoi volumes
C             pt_gtg will have the value of node first used
C             ...nbndry() are the number of shared voronoi boundaries
C             ...ndups() are the number of times node is used
C             ...bndryid is the id number of sink volume already set
C             ...bndrypt is the id number of current source node
              bndrypt=0

C             point id already is assigned for this source node
              if (pt_gtg(iisrc).gt.0) then
                if( if_search.eq.1) then
                  bndrypt=iisrc
                  bndryid=pt_gtg(iisrc)
                  nbndry(iisnk)= max(dups_gtg(iisrc),nbndry(iisnk))
                  ndups(iisnk)=ndups(iisnk)+1
                 endif
C             point id not yet assigned for this source node
              else
                pt_gtg(iisrc) = iisnk
              endif
              if (if_search.eq.1) then
                dups_gtg(iisrc) = dups_gtg(iisrc)+1
              endif
              nnum(iisnk)=nnum(iisnk)+1

              if (idebug.gt.6 .and. bndrypt.gt.0) then
                print*,iisnk," totals so far: "
                print*,"   accumulated points ",nnum(iisnk)
                print*,"   accumulated bndry points ",ndups(iisnk)
                print*,"   number shared boundaries ",nbndry(iisnk)
                print*,"   shared with sink node ",bndryid
                print*,"   shared with source node ",bndrypt
              endif

C             OPTION harave - harmonic average
              if(ntype.eq.1)then
                 if (xfield(iisrc).eq.0.) then
                    write(logmess,908)iisrc
908                 format(2x,"ERROR DIV ZERO: attribute of node ",2x,
     *              i15," equal to zero")
                    call writloga('default',0,logmess,0,ierrw)
                    stop
                 endif
                 value(iisnk)=value(iisnk)+1./xfield(iisrc)

C             OPTION ariave - arithmatic average
              elseif(ntype.eq.2)then
                 value(iisnk)=value(iisnk)+xfield(iisrc)

C             OPTION geoave - geometric average
              elseif(ntype.eq.3) then
                 if(xfield(iisrc).le.0.)then
                   write(logmess,909)iisrc
909                format(2x,"ERROR DIV ZERO: attribute of node",2x,
     *             i15," less than or equal to zero")
                    call writloga('default',0,logmess,0,ierrw)
                   stop
                 endif
                 value(iisnk)=value(iisnk)+log(xfield(iisrc))

C             OPTION sum
              elseif(ntype.eq.4)then

C               for single option, do not use a source point if
C               it has already been used for another Voronoi volumes
                if (bndrypt.gt.0) then
                  vor_bndry(iisnk)=vor_bndry(iisnk)+xfield(iisrc)
                  if (sum_opt(1:3).eq."sin") then
                    nnum(iisnk)=nnum(iisnk)-1
                  else
                    value(iisnk)=value(iisnk)+xfield(iisrc)
                  endif

                else
                  value(iisnk)=value(iisnk)+xfield(iisrc)

                endif

C             OPTION max
              elseif(ntype.eq.5)then
                 maxval = value(iisnk)
                 if (nnum(iisnk).eq.1) maxval=xfield(iisrc)
                 testval = xfield(iisrc)
                 value(iisnk)= max(testval,maxval)

C             OPTION min
              elseif(ntype.eq.6)then
                 minval = value(iisnk)
                 if (nnum(iisnk).eq.1) minval=xfield(iisrc)
                 testval = xfield(iisrc)
                 value(iisnk)= min(testval,minval)

              endif

            enddo
C           END LOOP OVER FOUND CANIDATES

            xs=xic(itfound(1))
            ys=yic(itfound(1))
            zs=zic(itfound(1))

C           Report progress so far
C           ii  is current node number in the fine source points
C           itfound is the coarse sink node (or nodes) for that point
            if(ipt.eq.1) then
               write(logmess,"(a)")
     *  '  Source Nodes    Percent Done'
               call writloga('default',1,logmess,0,ierrw)
            endif

            if((iwrite.eq.nwrite).and.(ipt.le.npoints_src)) then
               iwrite = 0
               write(logmess,"(i15,i9,a2)")
     *         ipt,istep*iperc,' %'
               call writloga('default',0,logmess,0,ierrw)
               totfind=0
               istep = istep + 1
            endif
            if (ipt.eq.npoints_src) then
                write(logmess,"(i15,a)")
     *         ipt,' Total source nodes searched.'
               call writloga('default',0,logmess,0,ierrw)
            endif
            iwrite=iwrite+1
            idone=ipt
            if (if_search.eq.0) then
                if (dups_gtg(ii).gt.1) ndups_tot=ndups_tot+1
            endif

         enddo
C        END LOOP through all source points

C       Release memory block
        call mmrelblk('distpossleaf' ,isubname,ipdistpossleaf,ierr)

C       NOW ASSIGN FINAL VALUES based on nnum, dups_gtg, and value
C       avoid divide by zero where 0 nodes found for sink
C       do nothing if no source points were found for the sink node
C       ..... iout and xout(iisrc) are the sink attributes
C       ..... value() was accumulated during the voronoi volume search
C       ..... nnum() are the number of src nodes for this sink node
C             if 0, then use initialized value()
        icntsink = 0
        icntsrc = 0
        do j=1,mpno
          ii=mpary(j)

          if (nnum(ii).eq.0) then
               if(ctype_snk.eq.'VINT')then
                  iout(ii)= nint( value(ii) )
               else
                  xout(ii)= value(ii)
               endif

          else  if (nnum(ii).gt.0) then
            icntsrc=icntsrc+nnum(ii)

c           harave
            if(ntype.eq.1) then
               if(ctype_snk.eq.'VINT')then
                  iout(ii)= nint( nnum(ii)/value(ii) )
               else
                  xout(ii)=nnum(ii)/value(ii)
               endif

c           ariave
            elseif(ntype.eq.2)then
               if(ctype_snk.eq.'VINT')then
                  iout(ii)= nint( value(ii)/nnum(ii) )
               else
                  xout(ii)=value(ii)/nnum(ii)
               endif

c           geoave
            elseif(ntype.eq.3) then
               if(ctype_snk.eq.'VINT')then
                  iout(ii)= nint(exp(dble(value(ii)/nnum(ii))))
               else
                  xout(ii)=exp(dble(value(ii)/nnum(ii)))
               endif

c           sum
            elseif(ntype.eq.4) then
               if(ctype_snk.eq.'VINT')then
                  iout(ii)= nint( value(ii) )
               else
                  xout(ii)=value(ii)
               endif

c           max and min
            elseif(ntype.eq.5 .or. ntype.eq.6) then
               if(ctype_snk.eq.'VINT')then
                  iout(ii)= nint( value(ii) )
               else
                  xout(ii)=value(ii)
               endif
            endif

C---        Report values per source node
            if (if_search.eq.1) then
              ndups_tot=ndups_tot+ndups(ii)
            endif
            if (idebug.gt.0 ) then

              if (idebug.gt.5) then

               if (ii.eq.1) then
                 write(logmess,"(a)")
     *      "---     Sink id   # of nodes used   calculated value ---"
                 call writloga('default',0,logmess,0,ierrw)
               endif
               if(ctype_snk.eq.'VINT')then
                 write(logmess,"(i15,2x,i15,3x,i15)")
     *           ii,nnum(ii),iout(ii)
               else
                 write(logmess,"(i15,2x,i15,3x,e14.7)")
     *           ii,nnum(ii),xout(ii)
               endif
               call writloga('default',0,logmess,0,ierrw)
              endif

              if (idebug.gt.1) then

                if (ndups(ii).gt.0) then
                 if(ctype_snk.eq.'VINT')then
                   write(logmess,"(a,i15,3x,i15)")
     *            "Duplicate nodes  ",ndups(ii),nint(vor_bndry(ii))
                 else
                   write(logmess,"(a,i15,3x,e14.7)")
     *            "Duplicate nodes  ", ndups(ii),vor_bndry(ii)
                 endif
                 call writloga('default',0,logmess,0,ierrw)
               endif

              endif

            endif
C---        end debug report

          endif
C         end switch assigning values based on numm nodes found
          if(nnum(ii) .ge. 1) icntsink=icntsink+1

        enddo
C       END LOOP through sink points to assign attribute values

C
C     ******************************************************************
C     DONE
C
      go to 9999
 9999 continue

C     Report error conditions
      if (ierror.ne.0) then
         write(logmess,'(a)') 'upscale quit with errors.'
         call writloga('default',1,logmess,0,ierrw)
      endif
      if (idone.ne.npoints_src) then
          write(logmess,"(a,i15,a,i15)") 'WARNING: ',
     *    idone,' source nodes searched out of ',npoints_src
          call writloga('default',1,logmess,0,ierrw)
      endif

C     Report number of sink points assigned values
      if (icntsink.gt.0) then
          write(logmess,"(i15,a,i15,a)") icntsink,
     * ' sink nodes out of   ',npoints,' assigned values.'
      else
        write(logmess,"(a)")
     * 'ERROR: UPSCALE found zero sink points for source points.'
      endif
      call writloga('default',0,logmess,0,ierrw)

C     Report number of source points used to assign values
      if (icntsrc.gt.0) then
          write(logmess,"(i15,a,i15,a)") icntsrc,
     * ' source nodes out of ',npoints_src,' used as source values.'
      else
        write(logmess,"(a)")
     * 'ERROR: UPSCALE found zero source nodes within Voronoi volumes.'
      endif
      call writloga('default',0,logmess,0,ierrw)

      if (ndups_tot.gt.0 .and. if_search.eq.1) then
         if (sum_opt(1:3).eq."sin") then
           write(logmess,"(i15,a)") ndups_tot,
     *     ' duplicate nodes on Voronoi boundaries used only once.'
         else
           write(logmess,"(i15,a)") ndups_tot,
     *     ' duplicate nodes on Voronoi boundaries used multiple times.'
         endif
         call writloga('default',0,logmess,0,ierrw)
      else if (ndups_tot.gt.0 .and. if_search.eq.0) then
          write(logmess,"(i15,a)") ndups_tot,
     *    ' duplicate nodes on Voronoi boundaries used only once.'
          call writloga('default',0,logmess,0,ierrw)
      endif

      write(logmess,"(a,a,a,a,a,a,a)")
     * 'UPSCALE/',intrp_opt(1:icharlnf(intrp_opt)),'/ from ',
     * attsrc(1:icharlnf(attsrc)), ' to ', attsnk(1:icharlnf(attsnk)),
     * ' Done.'
      call writloga('default',0,logmess,1,ierrw)
      ierror=0
      if(idebug.gt.0) call mmverify()

c     if attributes were created and not keeping, delete them now
      if(ikeep.ne.1 .and. ipt_exist.ne.0) then
        len=icharlnf(cmosrc)
        cbuff = 'cmo DELATT '//cmosrc(1:len)//'/pt_gtg ;  finish'
        call dotaskx3d(cbuff,ierr)
      endif
      if(ikeep.ne.1 .and. idups_exist.ne.0) then
        len=icharlnf(cmosrc)
        cbuff = 'cmo DELATT '//cmosrc(1:len)//'/dups_gtg ;  finish'
        call dotaskx3d(cbuff,ierr)
      endif

      len=icharlnf(cmosnk)
      cbuff = 'cmo select '//cmosnk(1:len)//' ;  finish'
      call dotaskx3d(cbuff,ierr)

C     ******************************************************************
C     RELEASE TEMPORARY MEMORY
C     call mmrelblk('mpary' ,isubname,ipmpary ,ics)
C     call mmrelblk('nneigh',isubname,ipnneigh,ics)
C     call mmrelblk('value',isubname,ipvalue,ics)
C     call mmrelblk('vor_bndry',isubname,ipvalue,ics)
C     call mmrelblk('nnum',isubname,ipnnum,ics)
C     call mmrelblk('ndups',isubname,ipnnum,ics)
C     call mmrelblk('nbndry',isubname,ipnnum,ics)
C     call mmrelblk('sbox' ,isubname,ipsbox,ics)
C     call mmrelblk('linkt' ,isubname,iplinkt,ics)
C     call mmrelblk('itfound' ,isubname,ipitfound,ics)

c     Return here if error is found before setup is done
 9000 if(ierror.ne.0) then
         write(logmess,'(a)')'FATAL ERROR: UPSCALE unable to begin.'
         call writloga('default',1,logmess,1,ierrw)
      endif
      if(if_search.gt.0) then
          call cmo_select(cmosnk,ierr)
          cbuff = 'cmo kdtree release ; finish'
          call dotaskx3d(cbuff,ierr)
      endif
      call mmrelprt(isubname,ics)
      call cmo_select(cmosnk,ierr)
C
      return
      end


PROGRAM DOORS

  INTEGER, PARAMETER :: n = 100    ! Number of doors
  INTEGER :: i
  LOGICAL :: door(n) = .TRUE.      ! Initially closed

  DO i = 1, SQRT(REAL(n))
    door(i*i) = .FALSE.
  END DO

  DO i = 1, n
    WRITE(*,"(A,I3,A)", ADVANCE="NO") "Door ", i, " is "
    IF (door(i)) THEN
      WRITE(*,"(A)") "closed"
    ELSE
      WRITE(*,"(A)") "open"
    END IF
  END DO

END PROGRAM DOORS


PROGRAM Assignment2
IMPLICIT NONE

INTEGER:: i, j, k, l, HalfMaxPos_Neg, HalfMaxPos_Pos
INTEGER, PARAMETER:: n=300
REAL:: DiffC, H, dt, TEnd, HalfMax, Errorpos, Errorneg, FWHM
double precision:: Temp(-n:n)=0.0, d2Tempdx2(-n:n), dTempdt(-n:n)=0.0
DiffC = 1.1; H = 0.1; tend = 10.0; dt=1E-4

DO i = -10, 10 !Creating Array of initial temp.
  Temp(i) = 20.0
END DO

OPEN(12, FILE = 'FWHM.dat')
WRITE(12,*) 'p ''FWHM.dat'' u 1:2 w l'

DO k = 0, Tend/dt !From 0 to 10 s in 100000 steps
  DO i = -n+1, n-1 !calculates the rate of change in temp for all x's
      dTempdt(i) = DiffC*(Temp(i+1)-2.0*Temp(i)+Temp(i-1))/H**2
  END DO
  DO j = -n+1, n-1 !calculates new temp for all x's
      Temp(j) = Temp(j)+dt*dtempdt(J) !new temp = rate of change in temp * change in time
  END DO
  HalfMax = Temp(0)/2; Errorpos =1; ErrorNeg = 1
  DO l = -n+1, n-1
    IF (l >= -n+1 .and. l < 0 .and. abs(HalfMax-Temp(l)) <= Errorneg ) THEN
       Errorneg = abs(HalfMax-Temp(l)); HalfMaxPos_Neg = L
       !WRITE(6,*) 'HalfMaxPos_Neg', HalfMaxPos_Neg
    ELSE IF (l <= n+1 .and. l>0 .and. abs(HalfMax-Temp(l)) <= Errorpos ) THEN
       Errorpos = abs(HalfMax-Temp(l)) ; HalfMaxPos_Pos = L
       !WRITE(6,*) 'HalfMaxPos_pos', HalfMaxPos_pos
    END IF
  END DO
   FWHM= REAL(HalfMaxPos_Pos-HalfMaxPos_Neg) * H

WRITE(6,*) Temp(0), 'fwhm', FWHM, Errorpos, errorneg, halfmax

WRITE(12,*) K, FWHM
CLOSE(12)
END DO

OPEN (11, FILE = 'Results.dat')
WRITE(11,*) 'p ''Results.dat'' u 1:2 w l'
  DO i = -n+1, n-1 !Prints results to file
    WRITE(11,*) i*0.1, Temp(i)
  END DO
CLOSE(11)

WRITE(6,*) 'Results, X, Temp, printed to file ''Results.dat''.'

END PROGRAM


subroutine geog_xy(fi,tet,h, x,y,z)
common/pi/pi,per
common/povorot/fi0,tet0,orient,sinal,cosal
rz=6371.

x1 = (rz-h)*SIN((fi-fi0)*per)*COS(tet*per)
y1 = (rz-h)*COS((fi-fi0)*per)*COS(tet*per)
z1 = (rz-h)*SIN(tet*per)

xx = x1
yy = -y1*SIN(tet0*per)+z1*COS(tet0*per)
zz = rz-(y1*COS(tet0*per)+z1*SIN(tet0*per))

x  = xx*cosal-yy*sinal
y  = xx*sinal+yy*cosal
z  = zz

return
end


program big_integer
!! this gets to 20! with int64 or 12! with int32
use, intrinsic :: iso_fortran_env, only : int64, real128

implicit none (type, external)

integer(int64) :: n, i, fac
integer :: ios
character(2) :: argv

n = 10
call get_command_argument(1, argv, status=ios)
if (ios==0) read(argv,'(i2)') n

if (n<0) error stop 'N >= 0 for factorial(N)'

fac = 1
do i = 1, n
  fac = fac * i
end do

! fac = gamma(real(n, real128))

print *, 'factorial',n,'=',fac

end program


C$Procedure      CYLSPH ( Cylindrical to spherical )

      SUBROUTINE CYLSPH ( R, LONGC, Z,  RADIUS, COLAT, LONG )

C$ Abstract
C
C     Convert from cylindrical to spherical coordinates.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     CONVERSION,  COORDINATES
C
C$ Declarations

      DOUBLE PRECISION    R
      DOUBLE PRECISION    LONGC
      DOUBLE PRECISION    Z
      DOUBLE PRECISION    RADIUS
      DOUBLE PRECISION    COLAT
      DOUBLE PRECISION    LONG

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  -------------------------------------------------
C     R          I   Distance of point from Z axis.
C     LONGC      I   Angle (radians) of point from XZ plane.
C     Z          I   Height of point above XY plane.
C     RADIUS     O   Distance of point from origin.
C     COLAT      O   Polar angle (co-latitude in radians) of point.
C     LONG       O   Azimuthal angle (longitude) of point (radians).
C
C$ Detailed_Input
C
C     R          Distance of the point of interest from Z axis.
C
C     LONGC      Cylindrical angle (radians) of the point from the
C                XZ plane.
C
C     Z          Height of the point above XY plane.
C
C$ Detailed_Output
C
C     RADIUS     Distance of the point from origin.
C
C     COLAT      Polar angle (co-latitude in radians) of the point.
C                The range of COLAT is [-pi, pi].
C
C     LONG       Azimuthal angle (longitude) of the point (radians).
C                LONG is set equal to LONGC.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This returns the spherical coordinates of a point whose position
C     is input through cylindrical coordinates.
C
C$ Examples
C
C     Below are two tables:  The first is a set of input values
C     the second is the result of the following sequence of
C     calls to SPICELIB routines.  Note all input and output angular
C     quantities are in degrees.
C
C         CALL CONVRT ( LONGC, 'DEGREES', 'RADIANS', LONGC       )
C
C         CALL CYLSPH ( R,      LONGC, Z,  RADIUS,   COLAT, LONG )
C
C         CALL CONVRT ( LONG,  'RADIANS', 'DEGREES', LONG        )
C         CALL CONVRT ( LAT,   'RADIANS', 'DEGREES', LAT         )
C
C
C
C     Inputs:                         Results:
C
C     R        LONGC    Z             RADIUS   LONG     COLAT
C     ------   ------   ------        ------   ------   ------
C     1.0000     0       0            1.0000     0       90.00
C     1.0000    90.00    0            1.0000    90.00    90.00
C     1.0000   180.00    1.000        1.4142   180.00    45.00
C     1.0000   180.00   -1.000        1.4142   180.00   135.00
C     0.0000   180.00    1.000        1.0000   180.00     0.00
C     0.0000    33.00    0            0.0000    33.00     0.00
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     W.L. Taber      (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.1.1, 26-JUL-2016 (BVS)
C
C        Minor headers edits.
C
C-    SPICELIB Version 1.1.0, 30-MAR-2016 (BVS)
C
C        A cosmetic change: replaced '0.0 D0's with '0.0D0's.
C        Re-arranged header sections.
C
C-    SPICELIB Version 1.0.2, 22-AUG-2001 (EDW)
C
C        Corrected ENDIF to END IF. Obsolete Revisions section
C        deleted.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (WLT)
C
C-&

C$ Index_Entries
C
C     cylindrical to spherical
C
C-&

C
C     Local variables
C
      DOUBLE PRECISION BIG
      DOUBLE PRECISION X
      DOUBLE PRECISION Y

      DOUBLE PRECISION RH
      DOUBLE PRECISION TH

C
C     Convert to spherical, storing in temporary variables
C
      BIG = MAX( DABS(R), DABS(Z) )

      IF ( BIG .EQ. 0.0D0 ) THEN

         TH = 0.0D0
         RH = 0.0D0

      ELSE

         X  = R/BIG
         Y  = Z/BIG

         RH = BIG * DSQRT( X*X + Y*Y )
         TH = DATAN2 (R,Z)

      END IF

C
C     Move the results to output variables
C
      LONG   = LONGC
      RADIUS = RH
      COLAT  = TH

      RETURN
      END


      PROGRAM xjacobi
C     driver for routine jacobi
      INTEGER NP,NMAT
      PARAMETER(NP=10,NMAT=3)
      INTEGER i,ii,j,jj,k,kk,l,ll,nrot,num(3)
      REAL ratio,d(NP),v(NP,NP),r(NP)
      REAL a(3,3),b(5,5),c(10,10),e(NP,NP)
      DATA num/3,5,10/
      DATA a/1.0,2.0,3.0,2.0,2.0,3.0,3.0,3.0,3.0/
      DATA b/-2.0,-1.0,0.0,1.0,2.0,-1.0,-1.0,0.0,1.0,2.0,
     *     0.0,0.0,0.0,1.0,2.0,1.0,1.0,1.0,1.0,2.0,
     *     2.0,2.0,2.0,2.0,2.0/
      DATA c/5.0,4.3,3.0,2.0,1.0,0.0,-1.0,-2.0,-3.0,-4.0,
     *     4.3,5.1,4.0,3.0,2.0,1.0,0.0,-1.0,-2.0,-3.0,
     *     3.0,4.0,5.0,4.0,3.0,2.0,1.0,0.0,-1.0,-2.0,
     *     2.0,3.0,4.0,5.0,4.0,3.0,2.0,1.0,0.0,-1.0,
     *     1.0,2.0,3.0,4.0,5.0,4.0,3.0,2.0,1.0,0.0,
     *     0.0,1.0,2.0,3.0,4.0,5.0,4.0,3.0,2.0,1.0,
     *     -1.0,0.0,1.0,2.0,3.0,4.0,5.0,4.0,3.0,2.0,
     *     -2.0,-1.0,0.0,1.0,2.0,3.0,4.0,5.0,4.0,3.0,
     *     -3.0,-2.0,-1.0,0.0,1.0,2.0,3.0,4.0,5.0,4.0,
     *     -4.0,-3.0,-2.0,-1.0,0.0,1.0,2.0,3.0,4.0,5.0/
      do 24 i=1,NMAT
        if (i.eq.1) then
          do 12 ii=1,3
            do 11 jj=1,3
              e(ii,jj)=a(ii,jj)
11          continue
12        continue
          call jacobi(e,3,NP,d,v,nrot)
        else if (i.eq.2) then
          do 14 ii=1,5
            do 13 jj=1,5
              e(ii,jj)=b(ii,jj)
13          continue
14        continue
          call jacobi(e,5,NP,d,v,nrot)
        else if (i.eq.3) then
          do 16 ii=1,10
            do 15 jj=1,10
              e(ii,jj)=c(ii,jj)
15          continue
16        continue
          call jacobi(e,10,NP,d,v,nrot)
        endif
        write(*,'(/1x,a,i2)') 'Matrix Number ',i
        write(*,'(1x,a,i3)') 'Number of JACOBI rotations: ',nrot
        write(*,'(/1x,a)') 'Eigenvalues:'
        do 17 j=1,num(i)
          write(*,'(1x,5f12.6)') d(j)
17      continue
        write(*,'(/1x,a)') 'Eigenvectors:'
        do 18 j=1,num(i)
          write(*,'(1x,t5,a,i3)') 'Number',j
          write(*,'(1x,5f12.6)') (v(k,j),k=1,num(i))
18      continue
C     eigenvector test
        write(*,'(/1x,a)') 'Eigenvector Test'
        do 23 j=1,num(i)
          do 21 l=1,num(i)
            r(l)=0.0
            do 19 k=1,num(i)
              if (k.gt.l) then
                kk=l
                ll=k
              else
                kk=k
                ll=l
              endif
              if (i.eq.1) then
                r(l)=r(l)+a(ll,kk)*v(k,j)
              else if (i.eq.2) then
                r(l)=r(l)+b(ll,kk)*v(k,j)
              else if (i.eq.3) then
                r(l)=r(l)+c(ll,kk)*v(k,j)
              endif
19          continue
21        continue
          write(*,'(/1x,a,i3)') 'Vector Number',j
          write(*,'(/1x,t7,a,t18,a,t31,a)')
     *         'Vector','Mtrx*Vec.','Ratio'
          do 22 l=1,num(i)
            ratio=r(l)/v(l,j)
            write(*,'(1x,3f12.6)') v(l,j),r(l),ratio
22        continue
23      continue
        write(*,*) 'press RETURN to continue...'
        read(*,*)
24    continue
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xjacobi.for


subroutine gjinv(a,ainv,n,np,det,flag)
!
!-----------------------------------------------
!
!      Gauss-Jordan elimination
!
!      a(n,n) .........the original matrix;
!      ainv(n,n) ......the computed inverse matrix;
!      n        .......the order of the matrix;
!      np      ........the dimension of the matrix;
!      det     ........the determinant of the matrix;
!      flag          = 1: the normal value
!                    =-1: singular value
!
!      June, 1994
!
!      Written and tested by Shaofan Li
!
!-----------------------------------------------
!
  implicit none

  integer n,np
  real(8) a(np,np),ainv(np,np),b(10,20)
  real(8) det, flag
  real(8) :: eps,sa,p,aik
  integer :: i,j,k,np1,npn,ipt,kp1,km1

  flag = 1.
  eps  = 1.0e-46

  if (n .gt. np)  then
     write(*,*) 'dimension range error !'
     stop
     go to 999
  endif

  do i = 1,n
     do j= 1, n
        b(i,j) = a(i,j)
     enddo
  enddo

  np1 = n + 1
  npn = n + n

  do i = 1,n
     do j = np1, npn
        b(i,j) = 0.0
     enddo
  enddo

  do i = 1,n
     j = n + i
     b(i,j) = 1.0
  enddo

  do k = 1,n
     kp1 = k +1
     if (k .eq. n ) go to 500
     ipt = k

     do i = kp1, n
        if(dabs(b(i,k)) .gt. dabs(b(ipt,k))) ipt = i
     enddo

     if (dabs(b(ipt,k)) .le. eps ) then
        flag = - flag
        write(*,*) 'inversion fails'
        stop
        go to 999
     endif

     if (ipt .eq. k) go to 500

     do j = k, npn
        sa       = b(k,j)
        b(k,j)   = b(ipt,j)
        b(ipt,j) = sa
     enddo

  500     do j = kp1, npn
         b(k,j) = b(k,j)/b(k,k)
     enddo

     if ( k .eq. 1) go to 600
     km1 = k -1

     do i = 1, km1
        do j = kp1, npn
           b(i,j) = b(i,j) - b(i,k)*b(k,j)
        enddo
     enddo

     if (k .eq. n) go to 700

  600    do i = kp1, n
        do j = kp1, npn
           b(i,j) = b(i,j) - b(i,k)*b(k,j)
        enddo
     enddo
  enddo

  700   do i = 1,n
     do j= 1,n
        k = j+n
        ainv(i,j) = b(i,k)
     enddo
  enddo
!
!.....Find the determinant det
!
  det = 1.0
  do k = 1, n
     p = a(k,k)
     do j = k, n
        a(k,j) = a(k,j)/p
     enddo

     do i = 1, n
        if(i-k .lt. 0) then
           aik = a(i,k)
        elseif(i-k .eq. 0) then
           go to 800
        elseif(i-k .gt. 0) then
           aik = a(i,k)
        endif

        do j = k,n
           a(i,j) = a(i,j) - aik*a(k,j)
        enddo
 800 enddo
     det = det * p
  enddo

  999  return
end


c
c This program computes the price of a European option (call and put)
c using the simple jump diffusion model of Kou (2002) discussed in Chapter 6
c of the book Tsay (2002).
c
c The program is intended for use in my course ``Analysis of Financial Time
c Series'' at GSB. I tested the program, but errors may still exist. Please
c bring any error to my attention.
c
c You may use the program at your own risk!  Ruey S. Tsay, December 2000.
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
      implicit double precision(a-h,o-z)
c
      write(6,1)
 1    format(1x,'Current and strike prices: ',$)
      read(5,*) pr, sk
      write(6,2)
 2    format(1x,'time to expiration (in years): ',$)
      read(5,*) dt
      write(6,3)
 3    format(1x,'Interest rate and volatility (std): ',$)
      read(5,*) free, sig
      if(sig .le. 0.0d0)then
       print*,'volatility must be positive!'
       stop
      endif
      write(6,4)
 4    format(1x,'lambda, kappa, eta: ',$)
      read(5,*) poi, rka, eta
      if((eta.le.0.0d0).or.(eta.gt.1.0d0))then
       print*,'eta is out of range!'
       stop
      endif
c
      nterm = 10
      write(6,5)
 5    format(1x,'terms of truncation? (default = 10): ',$)
      read(5,*) nterm
      if(nterm .le. 10) nterm = 10
      if(nterm .gt. 16) nterm = 16
c
      psi = dexp(rka)/(1.0d0-eta*eta)-1.0d0
      prsk = dlog(pr/sk)
      sigsrt = sig*dsqrt(dt)
      sig2h = sig*sig/2.0d0
      tlamb = poi*dt
      rtexp = dexp(-free*dt)
      ome1 = -prsk+tlamb*psi-(free-sig2h)*dt
      w1 = poi*psi*dt
      sigt = dexp(sig*sig*dt/(2.0d0*eta*eta))
      st2pi = dsqrt(6.28318530718d0)
      steta = sigsrt/eta
c
c----- compute the portion of geometric Brownian motion
      hp = (prsk+(free+sig2h-poi*psi)*dt)/sigsrt
      hm = (prsk+(free-sig2h-poi*psi)*dt)/sigsrt
      call gauss(hp,cdf1)
      call gauss(hm,cdf2)
      cgeo = dexp(-tlamb)*(pr*dexp(-w1)*cdf1-sk*rtexp*cdf2)
      print*,'Price due to the geometric part: ', cgeo
c---- compute the price for the jump process portion
c
      cj = 0.0d0
c
      do 100 n = 1, nterm
       tmp = dfloat(n)*rka/sigsrt
       bp = hp+tmp
       bm = hm+tmp
       ome = ome1-dfloat(n)*rka
       tmp1 = ome/sigsrt
       cp = steta+tmp1
       cm = steta-tmp1
       omexp = dexp(ome/eta)
       omexpi = dexp(-ome/eta)
       a11 = dexp(-w1+dfloat(n)*rka)*pr/2.0d0
       a22 = rtexp*omexpi*sigt*sk/2.0d0
       a33 = rtexp*omexp*sigt*sk/2.0d0
c
       call gauss(bp,cdf1)
       call gauss(bm,cdf2)
c
       fac = factor(n)
       npow = 2**(2*n-1)
       coef = (tlamb**n)*dexp(-tlamb)/fac
c
       a = 0.0d0
       do 50 j=1, n
        m = 2*n-j-1
        call comb(m,n-1,icnt)
        icnt = icnt*(2**j)
        coef1 = coef*dfloat(icnt)/dfloat(npow)
        a1 = (1.0d0/(1.0d0-eta)**j+1.0d0/(1.0d0+eta)**j)*a11*cdf1
     &   -rtexp*sk*cdf2
        a2 = 0.0d0
        a3 = 0.0d0
        do 30 ii=1, j
         i = ii-1
          w2 = 1.0d0/(1.0d0-eta)**(j-i)-1.0d0
          w2 = w2*(steta**i)*hh(cm,i)/st2pi
          w3 = 1.0d0-1.0d0/(1.0d0+eta)**(j-i)
          w3 = w3*(steta**i)*hh(cp,i)/st2pi
          a2 = a2 + w2
          a3 = a3 + w3
 30      continue
         a2 = a2*a22
         a3 = a3*a33
         a = coef1*(a1+a2+a3)+a
 50       continue
         cj = cj + a
 100      continue
c
      print*,'price due to jump component: ', cj
      c = cj + cgeo
      print*,'Price of a call: ', c
c
c---- put option
c
      p = c+sk*dexp(-free*dt)-pr
c
      print*,'Price of a put: ', p
c
      stop
      end
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine comb(m,n,icnt)
c----- combites the combinations
      implicit double precision(a-h,o-z)
      if((m .lt. n).or.(m .lt. 0))then
       icnt = 0
       return
      endif
      if(m.eq.n)then
       icnt = 1
       return
      endif
c
      n1 = 1
      do 5 j=n, 1, -1
 5       n1 = n1*j
c
      icnt = 1
      do 10 i=m, (m-n+1), -1
 10      icnt =icnt*i
      icnt = icnt/n1
      return
      end
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      double precision function factor(n)
      implicit double precision(a-h,o-z)
c
      if(n .lt. 0)then
        factor = 0.0d0
        return
       endif
       if(n.le. 1)then
        factor = 1.0d0
        return
       endif
       a = 1.0d0
       do 10 i=n, 1, -1
 10       a = a*dfloat(i)
       factor = a
c
       return
       end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      double precision function hh(x,n)
c
      implicit double precision(a-h,o-z)
      dimension h(100)
      if(n .gt. 100)then
       print*,'dimension in Hn function is too low!'
       stop
      endif
c
      pisqt = dsqrt(6.28318530718d0)
      h(1) = dexp(-x*x/2.0d0)
      if(n .eq. -1)then
       hh = h(1)
       return
      endif
      tmp = -x
      call gauss(tmp,cdf)
      h(2) = pisqt*cdf
      if(n .eq. 0)then
        hh = h(2)
        return
      endif
      do 40 j=3, 2+n
 40        h(j) = (h(j-2)-x*h(j-1))/dfloat(j-2)
 50        continue
c
       hh = h(n+2)
c
       return
       end
ccccccccccccccccccccccccccccccccccccccc
       subroutine gauss(x,cdf)
c
       implicit double precision(a-h,o-z)
       dimension a(5)
c
       a(1) = 0.319381530d0
       a(2) = -0.356563782d0
       a(3) = 1.781477937d0
       a(4) = -1.821255978d0
       a(5) = 1.330274429d0
c
c---------------- n: is used to indicate negative value.
       n = 0
c
       if(x .lt. 0.0d0) then
        x = -x
        n = 1
       endif
       xk = 1.0d0/(1.0d0+0.2316419d0*x)
       xf = dexp(-x*x/2.0d0)/dsqrt(6.28318530718d0)
       tmp = 0.0d0
       do 10 i=1, 5
 10       tmp = tmp + a(i)*xk**i
       cdf = 1.0d0-xf*tmp
       if(n.eq.1)cdf = 1.0d0-cdf
c
       return
       end
cccccccccccccccccccccccccccccccccccccc


 ! Stern-Brocot sequence - Fortran 90
      parameter (nn=2400)
      dimension isb(nn)
      isb(1)=1; isb(2)=1
      i=1; j=2; k=2
      do while(k.lt.nn)
        k=k+1; isb(k)=isb(k-i)+isb(k-j)
        k=k+1; isb(k)=isb(k-j)
        i=i+1; j=j+1
      end do
      n=15
      write(*,"(1x,'First',i4)") n
      write(*,"(15i4)") (isb(i),i=1,15)
      do j=1,11
        jj=j
        if(j==11) jj=100
        do i=1,k
          if(isb(i)==jj) exit
        end do
        write(*,"(1x,'First',i4,' at ',i4)") jj,i
      end do
      end


c=======================================================================
c  file: gaussj
c  routine: gaussj
c  solves linear system ax=b directly using Guassian Elimination
c  a(1:n,1:n) is the input matrix of size np by np
c  b(1:n,1:m) is the right hand side (can solve for m vectors)
c  On output a is replaced by it's inverse, and b replaced by x.

      SUBROUTINE gaussj(a,n,np,b,m,mp)
      INTEGER m,mp,n,np,NMAX
      REAL a(np,np),b(np,mp)
      PARAMETER (NMAX=50)
      INTEGER i,icol,irow,j,k,l,ll,indxc(NMAX),indxr(NMAX),ipiv(NMAX)
      REAL big,dum,pivinv
      do 11 j=1,n
        ipiv(j)=0
11    continue
      do 22 i=1,n
        big=0.
        do 13 j=1,n
          if(ipiv(j).ne.1)then
            do 12 k=1,n
              if (ipiv(k).eq.0) then
                if (abs(a(j,k)).ge.big)then
                  big=abs(a(j,k))
                  irow=j
                  icol=k
                endif

              else if (ipiv(k).gt.1) then
                write(*,*) 'singular matrix in gaussj'
              endif
12          continue
          endif
13      continue
        ipiv(icol)=ipiv(icol)+1
        if (irow.ne.icol) then
          do 14 l=1,n
            dum=a(irow,l)
            a(irow,l)=a(icol,l)
            a(icol,l)=dum
14        continue
          do 15 l=1,m
            dum=b(irow,l)
            b(irow,l)=b(icol,l)
            b(icol,l)=dum
15        continue
        endif
        indxr(i)=irow
        indxc(i)=icol
        if (a(icol,icol).eq.0.) write(*,*) 'singular matrix in gaussj'

        pivinv=1./a(icol,icol)
        a(icol,icol)=1.
        do 16 l=1,n
          a(icol,l)=a(icol,l)*pivinv
16      continue
        do 17 l=1,m
          b(icol,l)=b(icol,l)*pivinv
17      continue
        do 21 ll=1,n
          if(ll.ne.icol)then
            dum=a(ll,icol)
            a(ll,icol)=0.
            do 18 l=1,n
              a(ll,l)=a(ll,l)-a(icol,l)*dum
18          continue
            do 19 l=1,m
              b(ll,l)=b(ll,l)-b(icol,l)*dum
19          continue
          endif
21      continue
22    continue
      do 24 l=n,1,-1
        if(indxr(l).ne.indxc(l))then

          do 23 k=1,n
            dum=a(k,indxr(l))
            a(k,indxr(l))=a(k,indxc(l))
            a(k,indxc(l))=dum
23        continue
        endif
24    continue
      return
      END


c     main program
      implicit double precision (a-h,o-z)
      integer ierr
      parameter (max=8)
      dimension x(max),a(max,max),b(max)
c     input data
      write(6,*) 'gauss 消去法による Ax=bの計算(A:n*n x,b:n*1)'
      write(6,*) 'n='
      read(5,*) n
      call s_inmg(a,n,n,'a')
      call s_inmg(b,n,1,'b')

      call s_gauss(x,a,b,n,ierr)
      if(ierr.eq.1) then
        write(6,*) '不定または不能'
        stop
      end if
      call s_outm(x,n,1,'x')
      stop
      end

      subroutine s_gauss(x,a,b,n,ierr)
      implicit double precision (a-h,o-z)
      dimension x(n),a(n,n),b(n)
      parameter (e_eps=1.0e-14)
c     前進消去
      do 30 k=1,n-1
        call s_pivo(a,lc,n,k,ierr)
        if(ierr.eq.1) then
          return
        else if (le.ne.k) then
          tmp=b(k)
          b(k)=b(lc)
          b(lc)=tmp
        end if
        do 20 i=k+1,n
          a(i,j)=a(i,j)-p*a(k,j)
   10     continue
          b(i)=b(i)-p*b(k)
   20   continue
   30 continue
c   　 後退代入
      do 50 k=n,1,-1
        if(abs(a(k,k)).le.e_eps) then
          ierr=1
          return
        end if
          s=0.0
          do 40 j=k+1,n
            s=s+a(k,j)*x(j)
   40     continue
          x(k)=(b(k)-s)/a(k,k)
   50   continue
      ierr=0
      return
      end

      subroutine s_pivo(a,m,n,k,ierr)
      implicit double precision (a-h,o-z)
      dimension a(n,n)
      parameter (e_eps=1.0e-14)

      m=k
      d=abs(a(k,k))

      do 10 i=k+1,n
        if(abs(a(i,k)).gt.d) then
          m=i
          d=abs(a(i,k))
        end if
   10 continue

      if (abs(d).lt.e_eps) then
        ierr=1
        return
      else if(m.eq.k) then
        ierr=0
        return
      end if

      do 20 i=k,n
        tmp = a(k,i)
        a(k,i)=a(m,i)
        a(m,i)=tmp
   20 continue
      ierr=0
      return
      end
c     行列のキー入力サブルーチン
      subroutine s_inmg(a,n,m,name)
      implicit double precision (a-h,o-z)
      character name*1
      dimension a(n,m)
      write(6,*)
      do 20 i=1,n
        if(m.eq.1) then
            write(6,30) name ,i
   30       format(1h+,a,'(',i2,')の入力')
        else
            write(6,10) name,i,name,i,m
   10       format(1h+,a,'(',i2,', 1)~',a,'('i2,',',i2,')の入力')
        end if
            write(6,*)
            read(5,*)(a(i,j),j=1,m)
   20   continue
      return
      end

c     行列の画面表示サブルーチン
      subroutine s_outm(a,n,m,name)
      implicit double precision (a-h,o-z)
      character name*1
      dimension a(n,m)
      write(6,10) name
   10 format(1h,a,'=')
      do 30 i=1,n
        write(6,20)(a(i,j),j=1,m)
   20   format(8f15.6)
   30 continue
      return
      end


DO i = 2, SIZE(a)
   j = i - 1
   DO WHILE (j>=1 .AND. a(j) > a(i))
      j = j - 1
   END DO
   a(j+1:i) = cshift(a(j+1:i),-1)
END DO


program program_01
implicit none
integer, parameter :: dp=kind(0.d0)
real(dp) :: a
integer :: i
print *, "Normal random numbers:"
do i = 1, 10
    call rand(a)
    print *, a
end do

contains

    subroutine rand(x)
    ! Returns a psuedorandom scalar drawn from the standard normal distribution.
    !
    ! [1] Marsaglia, G., & Bray, T. A. (1964). A Convenient Method for
    !       Generating Normal Variables. SIAM Review, 6(3), 260–264.
    real(dp), intent(out) :: x
    logical, save :: first = .true.
    real(dp), save :: u(2)
    real(dp) :: r2
    if (first) then
        do
            call random_number(u)
            u = 2*u-1
            r2 = sum(u**2)
            if (r2 < 1 .and. r2 > 0) exit
        end do
        u = u * sqrt(-2*log(r2)/r2)
        x = u(1)
    else
        x = u(2)
    end if
    first = .not. first
    end subroutine

end program


PROGRAM factorial
INTEGER :: a
INTEGER :: sum
    READ *, a
    sum = 1
    ! Do is somewhat similar to for loop
    DO n = 1, a
        sum = sum * n
    END DO
    PRINT*, sum
END PROGRAM factorial


!> @brief application to perform box counting to estiamte the fractal
!>        dismension of an 2D object
!>
!> The application assumes that the 2D is in a unit square defined by
!> the points (0, 0), (1, 0), (0, 1), (1, 1).  A command line argument
!> specifies the resolution of the boxes, e.g., 2 means that 4 boxes
!> are used, 8 would mean 64 boxes.
!> Data is read from standard input in the form of x,y-coordinates in
!> the interval [0.0, 1.0].
!>
program box_counting
    use, intrinsic :: iso_fortran_env, only : error_unit, iostat_end, &
                                              DP => REAL64
    implicit none
    real(kind=DP) :: delta, x, y, numerator, denominator
    integer, dimension(:, :), allocatable :: counts
    integer :: nr_edges, istat, nr_non_empty

    ! get command line argument
    nr_edges = get_nr_edges()
    delta = 1.0_DP/nr_edges

    ! allocate the counts 2D array
    allocate(counts(nr_edges, nr_edges), stat=istat)
    if (istat /= 0) then
        write (unit=error_unit, fmt='(A)') &
            'Can not allocate counts'
        stop 2
    end if
    counts = 0

    ! read points and count
    do
        call get_coordinates(x, y, istat)
        if (istat == iostat_end) exit
        call box_count(counts, delta, x, y)
    end do

    ! display result
    nr_non_empty = count_non_empty(counts)
    numerator = log(real(nr_non_empty, kind=DP))
    denominator = log(real(nr_edges, kind=DP))
    print '(I7, 4E15.7)', nr_edges, delta, numerator, denominator, &
        numerator/denominator

    ! clean up
    deallocate(counts)

contains

    !> @brief validate command line argument and returns value of the
    !>        number of edges
    !> @returns number of edges
    function get_nr_edges() result(nr_edges)
        use, intrinsic :: iso_fortran_env, only : error_unit
        implicit none
        integer :: nr_edges
        character(len=1024) :: buffer, msg
        integer :: istat

        if (command_argument_count() /= 1) then
            write (unit=error_unit, fmt='(A)') &
                'error: expecting number of edges to define boxes'
            stop 1
        end if
        call get_command_argument(1, buffer)
        read (buffer, fmt=*, iostat=istat, iomsg=msg) nr_edges
        if (istat /= 0) then
            write (unit=error_unit, fmt='(2A)') &
                'error: ', msg
            stop 1
        end if
        if (nr_edges < 1) then
            write (unit=error_unit, fmt='(A)') &
                'error: number of edges is at least 1'
            stop 1
        end if
    end function get_nr_edges

    !> @brief read x, y coordinates from standard input
    !> @param[out] x coordinate
    !> @param[out] y coordinate
    !> @param[out] istat is 0 upon succesful read, `iostat_end` when
    !>             no input remains
    subroutine get_coordinates(x, y, istat)
        use, intrinsic :: iso_fortran_env, only : input_unit, error_unit
        implicit none
        real(kind=DP), intent(out) :: x, y
        integer, intent(out) :: istat
        character(len=1024) :: msg

        read (unit=input_unit, fmt=*, iostat=istat, iomsg=msg) x, y
        if (istat == iostat_end) return
        if (istat /= 0) then
            write (unit=error_unit, fmt='(2A)') &
                'error: ', msg
            stop 3
        end if
    end subroutine get_coordinates

    !> @brief update the box counts for the given coordinates
    !> @param[inout] counts the points in each of the boxes
    !> @param[in] delta is the length of the side of a box
    !> @param[in] x coordinate of the new point
    !> @param[in] y coordinate of the new point
    subroutine box_count(counts, delta, x, y)
        implicit none
        integer, dimension(:, :), intent(inout) :: counts
        real(kind=DP), intent(in) :: delta, x, y
        integer :: i, j

        i = 1 + int(x/delta)
        j = 1 + int(y/delta)
        ! if x or y is exactly equalt to 1, we lump it into the last box
        if (i > size(counts, 1)) i = i - 1
        if (j > size(counts, 1)) j = j - 1
        counts(i, j) = counts(i, j) + 1
    end subroutine box_count

    !> @brief return the number of boxes that have a non-zero count
    !> @param[in] counts of the boxes
    !> @returns the number of boxes with a non-zero count
    function count_non_empty(counts) result(nr_non_empty)
        implicit none
        integer, dimension(:, :), intent(in) :: counts
        integer :: nr_non_empty

        nr_non_empty = size(counts) - count(counts == 0)
    end function count_non_empty

end program box_counting


      SUBROUTINE AB13FD( N, A, LDA, BETA, OMEGA, TOL, DWORK, LDWORK,
     $                   CWORK, LCWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute beta(A), the 2-norm distance from a real matrix A to
C     the nearest complex matrix with an eigenvalue on the imaginary
C     axis. If A is stable in the sense that all eigenvalues of A lie
C     in the open left half complex plane, then beta(A) is the complex
C     stability radius, i.e., the distance to the nearest unstable
C     complex matrix. The value of beta(A) is the minimum of the
C     smallest singular value of (A - jwI), taken over all real w.
C     The value of w corresponding to the minimum is also computed.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A.  N >= 0.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             The leading N-by-N part of this array must contain the
C             matrix A.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     BETA    (output) DOUBLE PRECISION
C             The computed value of beta(A), which actually is an upper
C             bound.
C
C     OMEGA   (output) DOUBLE PRECISION
C             The value of w such that the smallest singular value of
C             (A - jwI) equals beta(A).
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             Specifies the accuracy with which beta(A) is to be
C             calculated. (See the Numerical Aspects section below.)
C             If the user sets TOL to be less than EPS, where EPS is the
C             machine precision (see LAPACK Library Routine DLAMCH),
C             then the tolerance is taken to be EPS.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C             If DWORK(1) is not needed, the first 2*N*N entries of
C             DWORK may overlay CWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= MAX( 1, 3*N*(N+2) ).
C             For optimum performance LDWORK should be larger.
C
C     CWORK   COMPLEX*16 array, dimension (LCWORK)
C             On exit, if INFO = 0, CWORK(1) returns the optimal value
C             of LCWORK.
C             If CWORK(1) is not needed, the first N*N entries of
C             CWORK may overlay DWORK.
C
C     LCWORK  INTEGER
C             The length of the array CWORK.
C             LCWORK >= MAX( 1, N*(N+3) ).
C             For optimum performance LCWORK should be larger.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  the routine fails to compute beta(A) within the
C                   specified tolerance. Nevertheless, the returned
C                   value is an upper bound on beta(A);
C             = 2:  either the QR or SVD algorithm (LAPACK Library
C                   routines DHSEQR, DGESVD or ZGESVD) fails to
C                   converge; this error is very rare.
C
C     METHOD
C
C     AB13FD combines the methods of [1] and [2] into a provably
C     reliable, quadratically convergent algorithm. It uses the simple
C     bisection strategy of [1] to find an interval which contains
C     beta(A), and then switches to the modified bisection strategy of
C     [2] which converges quadratically to a minimizer. Note that the
C     efficiency of the strategy degrades if there are several local
C     minima that are near or equal the global minimum.
C
C     REFERENCES
C
C     [1] Byers, R.
C         A bisection method for measuring the distance of a stable
C         matrix to the unstable matrices.
C         SIAM J. Sci. Stat. Comput., Vol. 9, No. 5, pp. 875-880, 1988.
C
C     [2] Boyd, S. and Balakrishnan, K.
C         A regularity result for the singular values of a transfer
C         matrix and a quadratically convergent algorithm for computing
C         its L-infinity norm.
C         Systems and Control Letters, Vol. 15, pp. 1-7, 1990.
C
C     NUMERICAL ASPECTS
C
C     In the presence of rounding errors, the computed function value
C     BETA  satisfies
C
C           beta(A) <= BETA + epsilon,
C
C           BETA/(1+TOL) - delta <= MAX(beta(A), SQRT(2*N*EPS)*norm(A)),
C
C     where norm(A) is the Frobenius norm of A,
C
C           epsilon = p(N) * EPS * norm(A),
C     and
C           delta   = p(N) * SQRT(EPS) * norm(A),
C
C     and p(N) is a low degree polynomial. It is recommended to choose
C     TOL greater than SQRT(EPS). Although rounding errors can cause
C     AB13FD to fail for smaller values of TOL, nevertheless, it usually
C     succeeds. Regardless of success or failure, the first inequality
C     holds.
C
C     CONTRIBUTORS
C
C     R. Byers, the routines QSEC and QSEC0 (January, 1995).
C
C     REVISIONS
C
C     Release 4.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1999.
C     V. Sima, Research Institute for Informatics, Bucharest, Apr. 2002,
C     Jan. 2003.
C
C     KEYWORDS
C
C     complex stability radius, distances, eigenvalue, eigenvalue
C     perturbation, norms.
C
C     ******************************************************************
C
C     .. Parameters ..
      INTEGER           MAXIT
      PARAMETER         ( MAXIT = 50 )
      DOUBLE PRECISION  ZERO, ONE, TWO
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
      COMPLEX*16        CONE
      PARAMETER         ( CONE = ( 1.0D0, 0.0D0 ) )
C     .. Scalar Arguments ..
      INTEGER           INFO, LCWORK, LDA, LDWORK, N
      DOUBLE PRECISION  BETA, OMEGA, TOL
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), DWORK(*)
      COMPLEX*16        CWORK(*)
C     .. Local Scalars ..
      INTEGER           I, IA2, IAA, IGF, IHI, ILO, ITNUM, IWI, IWK,
     $                  IWR, JWORK, KOM, LBEST, MINWRK, N2
      DOUBLE PRECISION  EPS, LOW, OM, OM1, OM2, SFMN, SIGMA, SV, TAU,
     $                  TEMP, TOL1
      LOGICAL           SUFWRK
C     .. Local Arrays ..
      DOUBLE PRECISION  DUMMY(1), DUMMY2(1,1)
C     .. External Functions ..
      DOUBLE PRECISION  DLAMCH, DLANGE, MB03NY
      EXTERNAL          DLAMCH, DLANGE, MB03NY
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DGEBAL, DGEMM, DHSEQR, DLACPY, DSYMM,
     $                  DSYMV, MA02ED, MB04ZD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, DBLE, INT, MAX, SQRT
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      INFO   = 0
      MINWRK = 3*N*( N + 2 )
C
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -3
      ELSE IF( LDWORK.LT.MAX( 1, MINWRK ) ) THEN
         INFO = -8
      ELSE IF( LCWORK.LT.MAX( 1, N*( N + 3 ) ) ) THEN
         INFO = -10
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'AB13FD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      OMEGA = ZERO
      IF ( N.EQ.0 ) THEN
         BETA = ZERO
         DWORK(1) = ONE
         CWORK(1) = CONE
         RETURN
      END IF
C
C     Indices for splitting the work array.
C     (Note: Comments in the code beginning "Workspace:" describe the
C     minimal amount of workspace needed at that point in the code,
C     as well as the preferred amount for good performance.)
C
      N2  = N*N
      IGF = 1
      IA2 = IGF + N2 + N
      IAA = IA2 + N2
      IWK = IAA + N2
      IWR = IAA
      IWI = IWR + N
C
      SUFWRK = LDWORK-IWK.GE.N2
C
C     Computation of the tolerances. EPS is the machine precision.
C
      SFMN = DLAMCH( 'Safe minimum' )
      EPS  = DLAMCH( 'Epsilon' )
      TOL1 = SQRT( EPS * DBLE( 2*N ) ) *
     $       DLANGE( 'Frobenius', N, N, A, LDA, DWORK )
      TAU  = ONE + MAX( TOL, EPS )
C
C     Initialization, upper bound at known critical point.
C     Workspace: need N*(N+1)+5*N; prefer larger.
C
      KOM = 2
      LOW = ZERO
      CALL DLACPY( 'All', N, N, A, LDA, DWORK(IGF), N )
      BETA = MB03NY( N, OMEGA, DWORK(IGF), N, DWORK(IGF+N2),
     $               DWORK(IA2), LDWORK-IA2, CWORK, LCWORK, INFO )
      IF ( INFO.NE.0 )
     $   RETURN
      LBEST = MAX( MINWRK, INT( DWORK(IA2) ) - IA2 + 1, 4*N2 + N )
C
      ITNUM = 1
C     WHILE ( ITNUM <= MAXIT and BETA > TAU*MAX( TOL1, LOW ) ) DO
   10 IF ( ( ITNUM.LE.MAXIT ) .AND.
     $     ( BETA.GT.TAU*MAX( TOL1, LOW ) ) ) THEN
         IF ( KOM.EQ.2 ) THEN
            SIGMA = BETA/TAU
         ELSE
            SIGMA = SQRT( BETA ) * SQRT( MAX( TOL1, LOW ) )
         END IF
C
C        Set up H(sigma).
C        Workspace: N*(N+1)+2*N*N.
C
         CALL DLACPY( 'Full', N, N, A, LDA, DWORK(IAA), N )
         DWORK(IGF)   =  SIGMA
         DWORK(IGF+N) = -SIGMA
         DUMMY(1) = ZERO
         CALL DCOPY( N-1, DUMMY, 0, DWORK(IGF+1), 1 )
C
         DO 20 I = IGF, IA2 - N - 2, N + 1
            CALL DCOPY( N+1, DWORK(I), 1, DWORK(I+N+1), 1 )
   20    CONTINUE
C
C        Computation of the eigenvalues by the square reduced algorithm.
C        Workspace: N*(N+1)+2*N*N+2*N.
C
         CALL MB04ZD( 'No vectors', N, DWORK(IAA), N, DWORK(IGF), N,
     $                DUMMY2, 1, DWORK(IWK), INFO )
C
C        Form the matrix A*A + F*G.
C        Workspace: need   N*(N+1)+2*N*N+N;
C                   prefer N*(N+1)+3*N*N.
C
         JWORK = IA2
         IF ( SUFWRK )
     $      JWORK = IWK
C
         CALL DLACPY( 'Lower', N, N, DWORK(IGF), N, DWORK(JWORK), N )
         CALL MA02ED( 'Lower', N, DWORK(JWORK), N )
C
         IF ( SUFWRK ) THEN
C
C           Use BLAS 3 calculation.
C
            CALL DSYMM( 'Left', 'Upper', N, N, ONE, DWORK(IGF+N), N,
     $                  DWORK(JWORK), N, ZERO, DWORK(IA2), N )
         ELSE
C
C           Use BLAS 2 calculation.
C
            DO 30 I = 1, N
               CALL DSYMV( 'Upper', N, ONE, DWORK(IGF+N), N,
     $                     DWORK(IA2+N*(I-1)), 1, ZERO, DWORK(IWK), 1 )
               CALL DCOPY( N, DWORK(IWK), 1, DWORK(IA2+N*(I-1)), 1 )
   30       CONTINUE
C
         END IF
C
         CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, N, ONE,
     $               DWORK(IAA), N, DWORK(IAA), N, ONE, DWORK(IA2), N )
C
C        Find the eigenvalues of A*A + F*G.
C        Workspace: N*(N+1)+N*N+3*N.
C
         JWORK = IWI + N
         CALL DGEBAL( 'Scale', N, DWORK(IA2), N, ILO, IHI, DWORK(JWORK),
     $                I )
         CALL DHSEQR( 'Eigenvalues', 'NoSchurVectors', N, ILO, IHI,
     $                DWORK(IA2), N, DWORK(IWR), DWORK(IWI), DUMMY2, 1,
     $                DWORK(JWORK), N, INFO )
C
         IF ( INFO.NE.0 ) THEN
            INFO = 2
            RETURN
         END IF
C
C        Count negative real axis squared eigenvalues. If there are two,
C        then the valley is isolated, and next approximate minimizer is
C        mean of the square roots.
C
         KOM = 0
         DO 40 I = 0, N - 1
            TEMP = ABS( DWORK(IWI+I) )
            IF ( TOL1.GT.SFMN ) TEMP = TEMP / TOL1
            IF ( ( DWORK(IWR+I).LT.ZERO ) .AND. ( TEMP.LE.TOL1 ) ) THEN
               KOM = KOM + 1
               OM = SQRT( -DWORK(IWR+I) )
               IF ( KOM.EQ.1 ) OM1 = OM
               IF ( KOM.EQ.2 ) OM2 = OM
            END IF
   40    CONTINUE
C
         IF ( KOM.EQ.0 ) THEN
            LOW = SIGMA
         ELSE
C
C           In exact arithmetic KOM = 1 is impossible, but if tau is
C           close enough to one, MB04ZD may miss the initial near zero
C           eigenvalue.
C           Workspace, real:    need   3*N*(N+2);  prefer larger;
C                      complex: need     N*(N+3);  prefer larger.
C
            IF ( KOM.EQ.2 ) THEN
               OM = OM1 + ( OM2 - OM1 ) / TWO
            ELSE IF ( KOM.EQ.1 .AND. ITNUM.EQ.1 ) THEN
               OM  = OM1 / TWO
               KOM = 2
            END IF
C
            CALL DLACPY( 'All', N, N, A, LDA, DWORK(IGF), N )
            SV = MB03NY( N, OM, DWORK(IGF), N, DWORK(IGF+N2),
     $                   DWORK(IA2), LDWORK-IA2, CWORK, LCWORK, INFO )
            IF ( INFO.NE.0 )
     $         RETURN
            IF ( BETA.GT.SV ) THEN
               BETA  = SV
               OMEGA = OM
            ELSE
               INFO = 1
               RETURN
            END IF
         END IF
         ITNUM = ITNUM + 1
         GO TO 10
C        END WHILE 10
      END IF
C
      IF ( BETA .GT. TAU*MAX( TOL1, LOW ) ) THEN
C
C        Failed to meet bounds within MAXIT iterations.
C
         INFO = 1
         RETURN
      END IF
C
C     Set optimal real workspace dimension (complex workspace is already
C     set by MB03NY).
C
      DWORK(1) = LBEST
C
      RETURN
C *** Last line of AB13FD ***
      END