text:
C    Copyright(C) 2014-2017 National Technology & Engineering Solutions of
C    Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    Redistribution and use in source and binary forms, with or without
C    modification, are permitted provided that the following conditions are
C    met:
C
C    * Redistributions of source code must retain the above copyright
C       notice, this list of conditions and the following disclaimer.
C
C    * Redistributions in binary form must reproduce the above
C      copyright notice, this list of conditions and the following
C      disclaimer in the documentation and/or other materials provided
C      with the distribution.
C
C    * Neither the name of NTESS nor the names of its
C      contributors may be used to endorse or promote products derived
C      from this software without specific prior written permission.
C
C    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
C    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
C    A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
C    OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
C    SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
C    LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
C    DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
C    THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
C    (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
C    OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
C

C $Id: snapxy.f,v 1.1 1990/11/30 11:15:59 gdsjaar Exp $
C $Log: snapxy.f,v $
C Revision 1.1  1990/11/30 11:15:59  gdsjaar
C Initial revision
C
C
CC* FILE: [.MAIN]SNAPXY.FOR
CC* MODIFIED BY: TED BLACKER
CC* MODIFICATION DATE: 7/6/90
CC* MODIFICATION: COMPLETED HEADER INFORMATION
C
      SUBROUTINE SNAPXY (MP, MSNAP, N, IPOINT, COOR, LINKP, SNAPDX,
     &   NSNAP)
C***********************************************************************
C
C  SUBROUTINE SNAPXY = ADDS SNAP GRIDS AT EVERY X, Y LOCATION
C
C***********************************************************************
C
      DIMENSION IPOINT (MP), COOR (2, MP), LINKP (2, MP)
      DIMENSION SNAPDX (2, MSNAP), NSNAP (2)
C
      LOGICAL ERR, ADDLNK
C
      ADDLNK = .FALSE.
C
      DO 100 I = 1, N
         CALL LTSORT (MP, LINKP, IABS (IPOINT (I)), II, ADDLNK)
         IF (II.GT.0)THEN
            INDEX = 1
            CALL ADDSNP (MSNAP, SNAPDX, NSNAP, INDEX, COOR (1, II), ERR)
            IF  (ERR) RETURN
            INDEX = 2
            CALL ADDSNP (MSNAP, SNAPDX, NSNAP, INDEX, COOR (2, II), ERR)
            IF  (ERR) RETURN
         ENDIF
  100 CONTINUE
C
      RETURN
C
      END

max_stars_repo_name: mathstuf/seacas

max_stars_repo_licenses: BSD-3-Clause NetCDF Zlib MIT

max_issues_repo_name: mathstuf/seacas

max_issues_repo_licenses: BSD-3-Clause NetCDF Zlib MIT

max_forks_repo_name: mathstuf/seacas

max_forks_repo_licenses: BSD-3-Clause NetCDF Zlib MIT


text:
      subroutine control_command_lg(ierror)
C#######################################################################
C
C     PURPOSE -
C
C        execute commands
C     INPUT
c
C     OUTPUT
C        ierror -- error flag (ierror=0 means no errors)
C
C     CHANGE HISTORY -
C
C        $Log: control_command_lg.f,v $
C        Revision 2.00  2007/11/05 19:45:51  spchu
C        Import to CVS
C
CPVCS
CPVCS       Rev 1.14   11 Apr 2002 15:29:56   gable
CPVCS    Added support for define/VAR/remove.
CPVCS    This allows one to release/remove a string so that
CPVCS    it no longer will be substituted with a definition
CPVCS    defined in a previous define command.
CPVCS
CPVCS       Rev 1.13   25 Mar 2002 16:55:10   dcg
CPVCS    replace definitions in the case of reusing names
CPVCS
CPVCS       Rev 1.12   08 Jun 2000 13:42:24   dcg
CPVCS    echo comments to outx3dgen
CPVCS
CPVCS       Rev 1.11   17 Feb 2000 21:37:22   jtg
CPVCS    added variable to count number of times "unexpected eof" hit
CPVCS    and stop code if number too great (currently hardwired at 1000).
CPVCS
CPVCS       Rev 1.10   Tue Aug 31 11:13:14 1999   dcg
CPVCS    check for an empty loop
CPVCS
CPVCS       Rev 1.9   Tue Jul 13 14:58:48 1999   dcg
CPVCS    more changes to handle comments correctly
CPVCS
CPVCS       Rev 1.8   Tue Jul 13 14:25:26 1999   dcg
CPVCS    skip comments that come in as dotasks
CPVCS
CPVCS       Rev 1.7   Wed Jun 23 14:05:58 1999   dcg
CPVCS    fix error in command stack management
CPVCS
CPVCS       Rev 1.6   Tue Jun 22 14:27:28 1999   dcg
CPVCS    allow infile from dotask to work
CPVCS
CPVCS       Rev 1.5   Wed Mar 31 16:45:06 1999   dcg
CPVCS    revert to interactive mode if stack error is encountered
CPVCS
CPVCS       Rev 1.4   Wed Mar 31 14:42:14 1999   dcg
CPVCS    set msgtype to zero before calling parse_string
CPVCS
CPVCS       Rev 1.3   Fri Mar 05 08:39:08 1999   dcg
CPVCS    change pack_command_lg to look for strings of blanks that
CPVCS    may or maynot be preceeded by other delimeters and
CPVCS    delete unnecessary blanks
CPVCS
CPVCS       Rev 1.2   Tue Feb 23 13:16:06 1999   dcg
CPVCS    handle ; correctly on read in lines
CPVCS
CPVCS       Rev 1.1   Mon Feb 22 20:46:18 1999   nnc
CPVCS    Deleted duplicate type specification.
CPVCS
CPVCS       Rev 1.0   Mon Feb 22 16:06:18 1999   dcg
CPVCS    Initial revision.
C
C#######################################################################
C
      implicit none
      include 'commands_lg.h'
      integer ierror

      integer icscode,nwds,jname,istrt,iend,i,nloop
      integer imsgout(maxcmd_args),msgtype(maxcmd_args),icharlnf,
     *  len1,len2,j,k,imatch,nremove,ioff,iunit
      real*8 xmsgout(maxcmd_args)
      character*32 cmsgout(maxcmd_args)
      character*32 isubname
c
CCCCCCCCCCCCCC
C begin

      ierror=0
      isubname="control_command_lg"

c  access definitions list
      call mmfindbk('definition',initname,ipdefinition,i,icscode)
c
c  check state and get next command from stack
c
100   if(clevels(nlevels)(1:11).ne.'internal_lg') then
         if(last_char.le.0.or.
     *       clevels(nlevels).ne.'interactive_lg') then
             call read_command_lg(ierror)
             call push_command_lg(ierror)
         endif
      endif
      command=' '
      error_msg=' '
      call pop_command_lg(ierror)
      nloop=(len_cmd+79)/80
      istrt=1
      iend=min(80,len_cmd)
      do i=1,nloop
         write(error_msg,'(a)') command(istrt:iend)
         call writloga('tty',0,error_msg,0,icscode)
         call writloga('bat',0,error_msg,0,icscode)
         if(clevels(nlevels)(1:11).ne.'internal_lg')
     *    call writloga('log',0,error_msg,0,icscode)
         istrt=istrt+80
         iend=min(len_cmd,iend+80)
      enddo
      if (command.eq.' '.or.ierror.ne.0) then
         write(error_msg,9000)
 9000    format ('empty command stack or other stack error',
     *       ' revert to previous mode')
         call writloga('default',0,error_msg,0,icscode)
         if(clevels(nlevels).eq.'internal_lg') then
           nlevels=nlevels-1
         else
           nlevels=1
           clevels(nlevels)='interactive_lg'
         endif
         go to 100
      endif
c process finish command
      if(command(1:6).eq.'finish') then

         if( clevels(nlevels).ne.'interactive_lg'.and.
     *       clevels(nlevels).ne.'internal_lg') then
           close(jlevels(nlevels))
         endif
         nlevels=nlevels-1

         if(nlevels.eq.0) then
           write(error_msg,9001)
 9001      format ('LaGriT successfully completed')
           call writloga('default',0,error_msg,0,icscode)
           go to 9999
         endif
         if(clevels(nlevels+1)(1:11).eq.'internal_lg') go to 9999
         go to 100
      endif

c parse command
      do i=1,maxcmd_args
         msgtype(i)=0
      enddo
      call parse_string(imsgout,msgtype,xmsgout,cmsgout,nwds)
c  handle file change commands
      if(cmsgout(1)(1:6).eq.'infile'.or.
     *   cmsgout(1)(1:5).eq.'input') then
         if (nwds.lt.2) then
            ierror=1
            write(error_msg,9002) cmsgout(1)(1:6)
 9002  format ('Error: file name missing from command : ',a)
            call writloga('default',0,error_msg,0,icscode)
            go to 100
         endif
c
c  expand definitions if found
         call substitute_defs_lg(msgtype,imsgout,xmsgout,cmsgout,
     *        nwds,ierror)
c
         nlevels=nlevels+1
         clevels(nlevels)=cmsgout(2)
         iunit=-1
         call hassign(iunit,clevels(nlevels),icscode)
         if (iunit.lt.0 .or. icscode.lt.0) then
           write(error_msg,'(a,i5)')
     *     'hassign bad file unit : ',iunit
           call writloga('default',0,error_msg,0,icscode)
           write(error_msg,'(a)') 'Error: infile not used.'
           call writloga('default',0,error_msg,1,icscode)
         endif
         jlevels(nlevels)=iunit
         go to 100

c  handle define commands
      elseif(cmsgout(1)(1:6).eq.'define') then
         if(ndefinitions+2.ge.maxdefinitions) then
            ierror=1
            write(error_msg,9003) cmsgout(2)(1:32)
 9003       format ('maximum number of definitions exceeded : ',a)
            call writloga('default',0,error_msg,0,icscode)
            go to 100
         endif
c
c  look for existing definition and remove name
c
         len1=icharlnf(cmsgout(2))
         imatch=0
         do j=1,ndefinitions
           len2=icharlnf(definitions_name(j))
           if (len1.eq.len2) then
              if (definitions_name(j)(1:len1).eq.cmsgout(2)(1:len1))
     *           then
                 imatch=1
c
c  compress lists
c
                 nremove=definitions_off(j+1)-definitions_off(j)
                 ioff=definitions_off(j)
                 do k=1,definitions_off(ndefinitions+1)-ioff
                    definition(ioff+k-1:ioff+k-1)=
     *                 definition(definitions_off(j+1)+k-1:
     *                            definitions_off(j+1)+k-1 )
                 enddo
                 lastchar_def=lastchar_def-(definitions_off(j+1)-
     *              definitions_off(j))
                 do k=j+1,ndefinitions
                    definitions_name(k-1)=definitions_name(k)
                 enddo
                 do k=j+1,ndefinitions
                    definitions_off(k)=definitions_off(k+1)-nremove
                 enddo
              endif
           endif
         enddo
       if( (nwds .gt. 2) .and.
     *    ((cmsgout(3)(1:7) .eq. 'release') .or.
     *     (cmsgout(3)(1:6) .eq. 'remove' )))then
c
c      Definition removed above, reduce list by one.
c
             ndefinitions = ndefinitions - 1
       else
c
c  make new definition entry
c
         if(imatch.eq.0) ndefinitions=ndefinitions+1
         definitions_name(ndefinitions)=cmsgout(2)
         len1=icharlnf(cmsgout(3))
         definition(lastchar_def+1:lastchar_def+len1)=cmsgout(3)
         definitions_off(ndefinitions)=lastchar_def+1
         lastchar_def=lastchar_def+len1
         definitions_off(ndefinitions+1)=lastchar_def+1
       endif
c
      else
c
c  expand definitions if found
         call substitute_defs_lg(msgtype,imsgout,xmsgout,cmsgout,
     *        nwds,ierror)
c
c  go to msgtty to process other commands
c
         ierror = 0
         call msgtty(imsgout,msgtype,xmsgout,cmsgout,nwds,ierror)
         if (ierror.ne.0) then
              ierror=1
              write(error_msg,9004) command(1:80)
 9004         format ('error in command : ',a80)
              call writloga('default',0,error_msg,0,icscode)
              go to 100
         endif
      endif
      go to 100
 9999 return
      end
c
      subroutine substitute_defs_lg(msgtype,imsgout,xmsgout,cmsgout,nwds
     *  ,ierror)
C#######################################################################
C
C     PURPOSE -
C
C        substitute definitions into cmsgout if found
C     INPUT
c
c        msgtype  type of input token
c        imsgout  integer input tokens
c        xmsgout  real input tokens
c        cmsgout  character input tokens
c        nwds     number of input tokens
c
C     OUTPUT
C        ierror -- error flag (ierror=0 means no errors)
C
C     CHANGE HISTORY -
C
C        $Log: control_command_lg.f,v $
C        Revision 2.00  2007/11/05 19:45:51  spchu
C        Import to CVS
C
C
C#######################################################################
C
      implicit none
      include 'commands_lg.h'
      integer ierror,nwds,msgtype(nwds),imsgout(nwds)
      character*32 cmsgout(*)
      integer i,j,len1,len2,icharlnf,icscode,i1
      real*8 xmsgout(nwds),x1
      logical isintgrvar, isrlvar
c  access definitions list
      call mmfindbk('definition',initname,ipdefinition,i,icscode)
c
      ierror=0
      do i=1,nwds
         if(msgtype(i).eq.3) then
            len1=icharlnf(cmsgout(i))
            do j=1,ndefinitions
               len2=icharlnf(definitions_name(j))
               if (len1.eq.len2) then
                 if (definitions_name(j)(1:len1).eq.cmsgout(i)(1:len1))
     *              then
                    cmsgout(i)=definition(definitions_off(j):
     *                                    definitions_off(j+1)-1)
                    len1=icharlnf(cmsgout(i))
C
c  change type if necessary
c
                    call isinteger_lg(cmsgout(i),len1,i1,isintgrvar)
                    if(isintgrvar) then
                       msgtype(i)=1
                       imsgout(i)=i1
                    else
                       call isrl_lg(cmsgout(i),len1,x1,isrlvar)
                       if(isrlvar) then
                           msgtype(i)=2
                           xmsgout(i)=x1
                       endif
                    endif
                 endif
               endif
            enddo
         endif
      enddo
      return
      end
c
      subroutine push_command_lg(ierror)
C#######################################################################
C
C     PURPOSE -
C
C        put the command in cmd_buff into cmd_stack
C     INPUT
c
C     OUTPUT
C        ierror -- error flag (ierror=0 means no errors)
C
C     CHANGE HISTORY -
C
C        $Log: control_command_lg.f,v $
C        Revision 2.00  2007/11/05 19:45:51  spchu
C        Import to CVS
C
C
C#######################################################################
C
      implicit none
      include 'commands_lg.h'
      integer ierror,nloop,n,ib,ie,nmove,icscode
c      pointer (ipcmd_stack,cmd_stack)
c      character*100000 cmd_stack
c
c  access cmd_stack
      call mmfindbk('cmd_stack',initname,ipcmd_stack,n,icscode)
c
c  check that max length is not exceeded
c
      if(last_char+len_buff.gt.maxlen_stack) then
         maxlen_stack=maxlen_stack+4096
         call mmincblk('cmd_stack',initname,ipcmd_stack,1024,
     *     icscode)
      endif
c
c  make room for cmd_buff at front of cmd_stack
C
      nmove=len_buff
      nloop=(nmove+maxlen_buff-1)/maxlen_buff
      ib=1
      ie=last_char
      if(ie.eq.0) nloop=0
      do n=nloop,1,-1
         nmove=ie-ib+1
         cmd_temp(1:nmove)=cmd_stack(ib:ie)
         cmd_stack(ib+len_buff:ie+len_buff)=cmd_temp(1:nmove)
         ib=ib-maxlen_buff
         ie=ie-maxlen_buff
         if(ib.le.0) ib=1
      enddo
      cmd_stack(1:len_buff)=cmd_buff(1:len_buff)
      ierror=0
      last_char=last_char+len_buff
 9999 return
      end
      subroutine pop_command_lg(ierror)
C#######################################################################
C
C     PURPOSE -
C
C        pop the top command from cmd_stack into command
C     INPUT
c
C     OUTPUT
C        ierror -- error flag (ierror=0 means no errors)
C
C     CHANGE HISTORY -
C
C        $Log: control_command_lg.f,v $
C        Revision 2.00  2007/11/05 19:45:51  spchu
C        Import to CVS
C
C
C#######################################################################
C
      implicit none
      include 'commands_lg.h'
      integer ierror,nloop,n,ib,ie,nmove,icscode,idx,iend
c      pointer (ipcmd_stack,cmd_stack)
c      character*100000 cmd_stack
c
c  access cmd_stack
      call mmfindbk('cmd_stack',initname,ipcmd_stack,n,icscode)
c
c  check that stack is not empty
c
 5    len_cmd=0
      if(last_char.le.0) then
         ierror=1
         write(error_msg,9000)
 9000    format (' command stack empty ',
     *     a)
         call writloga('default',0,error_msg,0,icscode)
         go to 9999
      endif
c
c  get the top command off cmd_stack
C
      idx=0
      ierror=0
      idx=index(cmd_stack(1:maxlen_stack),';')
      if(idx.eq.0) then
         idx=last_char
         len_cmd=idx
      elseif (idx.gt.0) then
         len_cmd=idx-1
      else
         ierror=1
         go to 9999
      endif
      command(1:len_cmd)=cmd_stack(1:len_cmd)
      nmove=last_char-idx
      nloop=(nmove+maxlen_buff-1)/maxlen_buff
      ib=1
      ie=min(nmove,maxlen_buff)
      do n=1,nloop
         cmd_temp(1:ie)=cmd_stack(ib+idx:ie+idx)
         cmd_stack(ib:ie)=cmd_temp(1:ie)
         ib=ib+maxlen_buff
         ie=ie+maxlen_buff
         if(ie.gt.last_char) ie=last_char
      enddo
      ierror=0
      last_char=last_char-idx
      cmd_stack(last_char+1:len_cmd)=' '
cTAM  cmd_stack(last_char+1:maxlen_stack)=' '
c
c  get rid of leading blanks in command
c
      if(command(1:1).ne.' ') go to 9998
      cmd_temp=' '
      cmd_temp=command
      iend=1
      dowhile (command(iend+1:iend+1).eq.' ')
        iend=iend+1
      enddo
      command(1:len_cmd-iend)=cmd_temp(iend+1:len_cmd)
      command(len_cmd-iend+1:len_cmd)=' '
      len_cmd=len_cmd-iend
c
c  skip commands that are comments
c
 9998 if(command(1:1).eq.'*'.and.last_char.ne.0) go to 5
 9999 return
      end
c
      subroutine pack_command_lg(ierror)
C#######################################################################
C
C     PURPOSE -
C
C        get rid of leading, trailing and embedded blanks
C            in cmd_buff
C        make sure it terminates with a ';'
C     INPUT
c
C     OUTPUT
C        ierror -- error flag (ierror=0 means no errors)
C
C     CHANGE HISTORY -
C
C        $Log: control_command_lg.f,v $
C        Revision 2.00  2007/11/05 19:45:51  spchu
C        Import to CVS
C
C
C#######################################################################
C
      implicit none
      include 'commands_lg.h'
      integer len1,i,istrt,iend,ierror,idelb
c
      ierror=0
C
C  look for trailing blanks
C
      len1=maxlen_buff
      len_buff=len1
      do i=len1,1,-1
        if(cmd_buff(i:i).eq.' ') then
           len_buff=len_buff-1
        else
           go to 100
        endif
      enddo
C
C  look for terminal ';'
C
 100  len1=len_buff
      if (cmd_buff(len1:len1).ne.';') then
         cmd_buff(len1+1:len1+1)=';'
         len_buff=len_buff+1
      endif
c
c  look for leading blanks
c
      len1=len_buff
      istrt=1
      do i=1,len1
         if(cmd_buff(i:i).eq.' ') then
           istrt=istrt+1
         else
           go to 200
         endif
      enddo
 200  if(istrt.gt.1) then
         do i=istrt,len1
            cmd_buff(i-istrt+1:i-istrt+1)=cmd_buff(i:i)
         enddo
         len_buff=len_buff-istrt+1
      endif
C
C  look for embedded blanks
c  look also for delimiter followed or preceeded by a blank
c  and remove these unneeded blanks
c
      len1=len_buff
      istrt=0
 250  i=index(cmd_buff(istrt+1:len1),' ')
      if(i.eq.0) go to 9999
      istrt=i+istrt
      if (istrt.le.0.or.istrt.gt.len1) go to 9999
c
c  get length of blank string
c
      idelb=1
      iend=istrt
      do while (cmd_buff(iend+1:iend+1).eq.' ')
         iend=iend+1
         idelb=idelb+1
      enddo
c
c  if string of blanks is preceeded or followed
c  by a delimeter - get rid of all the blanks
c  otherwise keep one as the blank is the delimeter
c
      if(cmd_buff(istrt-1:istrt-1).ne.','.and.
     *   cmd_buff(istrt-1:istrt-1).ne.'/'.and.
     *   cmd_buff(istrt-1:istrt-1).ne.';'.and.
     *   cmd_buff(istrt-1:istrt-1).ne.'='.and.
     *   cmd_buff(iend+1:iend+1).ne.','.and.
     *   cmd_buff(iend+1:iend+1).ne.'/'.and.
     *   cmd_buff(iend+1:iend+1).ne.'='.and.
     *   cmd_buff(iend+1:iend+1).ne.';') then
         istrt=istrt+1
         idelb=idelb-1
      endif
 300  if(idelb.gt.0) then
         do i=istrt,len1-(iend+1-istrt)
            cmd_buff(i:i)=cmd_buff(i+(iend+1-istrt):i+(iend+1-istrt))
         enddo
         len1=len1-(iend+1-istrt)
         len_buff=len1
      endif
      go to 250
 9999 len_buff=len1
      return
      end
c
      block data data_read_command_lg
C#######################################################################
C
C     PURPOSE -
C
C        initialize n_hits, variable to avoid inf loop in read_command_lg
C
C#######################################################################
C
      implicit none
      integer n_hits
      common /common_read_command_lg/ n_hits
      save /common_read_command_lg/
      data n_hits / 0 /
      end

      subroutine read_command_lg(ierror)
C#######################################################################
C
C     PURPOSE -
C
C        read a file for next input lines
C
C     INPUT
c
C     OUTPUT
C        ierror -- error flag (ierror=0 means no errors)
C
C     CHANGE HISTORY -
C
C        $Log: control_command_lg.f,v $
C        Revision 2.00  2007/11/05 19:45:51  spchu
C        Import to CVS
C
C
C#######################################################################
C
      implicit none
      include 'commands_lg.h'
      integer ifile,jstrt,ib,ie,icscode,ierror
      integer n_hits
      common /common_read_command_lg/ n_hits
      save /common_read_command_lg/
c
      ierror=0
c
c  check state - if interactive prompt for command
c
      if(clevels(nlevels)(1:14).eq.'interactive_lg') then
         write(*, 9000)
 9000    format (' Enter a command')
      endif
c
c  get unit number
c
      ifile=jlevels(nlevels)
c
c  read a line and look for continuation
c
      jstrt=0
 5    if(clevels(nlevels)(1:14).eq.'interactive_lg') then
         read(*,'(a80)',end=1000) cmd_buff
      else
         read(ifile,'(a80)',end=1000) cmd_buff
      endif
c
c  check for comment - if so print and go to next command
c
      if((cmd_buff(1:1).eq.'*').or.(cmd_buff(1:1).eq.'#')) then
         write(error_msg,'(a)')cmd_buff(1:80)
         call writloga('default',0,error_msg,0,icscode)
         if (clevels(nlevels)(1:14).eq.'interactive_lg')
     *      write(*,9000)
         go to 5
      endif
c
c  check for blank line - if so print and go to next command
c
      if(cmd_buff(1:80).eq.' ') then
         write(*,'(a)')cmd_buff(1:80)
         go to 5
      endif
c
  10  jstrt=index(cmd_buff,'&')
      if(jstrt.ne.0) then
c
c  found continuation - leave one blank at end as separator
c  tokens cannot be split between lines
c
         cmd_buff(jstrt:jstrt)=' '
         dowhile(cmd_buff(jstrt-2:jstrt-2).eq.' ')
            jstrt=jstrt-1
         enddo
c
c  read continuation lines
c
         if(clevels(nlevels)(1:14).eq.'interactive_lg') then
            read(*,'(a80)',end=1000) cline
         else
            read(ifile,'(a80)',end=1000) cline
         endif
         if(cline.eq.' ') go to 9999
         ib=1
         ie=80
         dowhile (cline(ib:ib).eq.' ')
           ib=ib+1
         enddo
         dowhile (cline(ie:ie).eq.' ')
           ie=ie-1
         enddo
         if(jstrt+ie-ib.gt.maxlen_buff) then
            write(error_msg,9001)
 9001       format('max command buffer length exceeded-command ignored')
            call writloga('default',0,error_msg,0,icscode)
            ierror=1
            cmd_buff=' '
            go to 9999
         endif
         cmd_buff(jstrt:jstrt+ie-ib)=cline(ib:ie)
         go to 10
      endif
c
c  get rid of extra blanks
c
      call pack_command_lg(ierror)
      go to 9999
 1000 write(error_msg,9002)
 9002 format('unexpected eof-command ignored')
      call writloga('default',0,error_msg,0,icscode)
      n_hits=n_hits+1
      if (n_hits.gt.1000) stop 'maximum number hit, code aborting'
      ierror=1
      cmd_buff=' '
      go to 9999
9999  return
      end

ext: f

max_forks_repo_name: daniellivingston/LaGriT


text:
dash7/driver.cpp
dash7/dist.cpp
dash7/main.cpp
dash7/pulse.cpp
dash7/speed.cpp


text:
*dk,isamax
      integer function isamax(N,SX,INCX)
C
C ######################################################################
C
C        $Log: isamax.f,v $
C        Revision 2.00  2007/11/03 00:49:11  spchu
C        Import to CVS
C
CPVCS
CPVCS       Rev 1.21   02 Oct 2007 12:40:28   spchu
CPVCS    original version
C
C ######################################################################
C
      implicit real*8 (a-h,o-z)
c  this function operates as double precision on short word machines
C***BEGIN PROLOGUE  isamax
C***DATE WRITTEN   791001   (YYMMDD)
C***REVISION DATE  861211   (YYMMDD)
C***CATEGORY NO.  D1A2
C***KEYWORDS  LIBRARY=SLATEC(BLAS),
C             TYPE=SINGLE PRECISION(isamax-S IDAMAX-D ICAMAX-C),
C             LINEAR ALGEBRA,MAXIMUM COMPONENT,VECTOR
C***AUTHOR  LAWSON, C. L., (JPL)
C           HANSON, R. J., (SNLA)
C           KINCAID, D. R., (U. OF TEXAS)
C           KROGH, F. T., (JPL)
C***PURPOSE  Find the smallest index of that component af a vector
C            having the maximum magnitude.
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C        N  number of elements in input vector(s)
C       SX  single precision vector with N elements
C     INCX  storage spacing between elements of SX
C
C     --Output--
C   isamax  smallest index (zero if N .LE. 0)
C
C     Find smallest index of maximum magnitude of single precision SX.
C     isamax =  first I, I = 1 to N, to minimize  ABS(SX(1-INCX+I*INCX)
C***REFERENCES  LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T.,
C                 *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*,
C                 ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL
C                 SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  isamax
C
      real*8 SX(N),SMAX,XMAG
C***FIRST EXECUTABLE STATEMENT  isamax
      isamax = 0
      IF(N.LE.0) RETURN
      isamax = 1
      IF(N.LE.1)RETURN
      IF(INCX.EQ.1)GOTO 20
C
C        CODE FOR INCREMENTS NOT EQUAL TO 1.
C
      SMAX = ABS(SX(1))
      NS = N*INCX
      II = 1
          DO 10 I=1,NS,INCX
          XMAG = ABS(SX(I))
          IF(XMAG.LE.SMAX) GO TO 5
          isamax = II
          SMAX = XMAG
    5     II = II + 1
   10     CONTINUE
      RETURN
C
C        CODE FOR INCREMENTS EQUAL TO 1.
C
   20 SMAX = ABS(SX(1))
      DO 30 I = 2,N
         XMAG = ABS(SX(I))
         IF(XMAG.LE.SMAX) GO TO 30
         isamax = I
         SMAX = XMAG
   30 CONTINUE
      RETURN
      END


text:
module cuda_data_wrapper_module
    use, intrinsic :: iso_c_binding, only : &
        c_ptr, &
        c_size_t, &
        c_int

    implicit none
    private

    public :: cuda_update_device
    public :: cuda_update_host
    public :: cuda_update_device_async
    public :: cuda_update_device_async_with_stream
    public :: cuda_update_host_async
    public :: cuda_update_host_async_with_stream
    public :: cuda_device2device
    public :: cuda_device2device_with_stream
    public :: cudamemgetinfo

    integer, public, parameter :: CUDA_DATA_SUCCESS = 0

    interface
        integer(c_int) function cuda_update_device( dst, src, nbytes) &
                                                bind(c, name="cuda_update_device")
            import :: c_ptr, c_size_t, c_int
            type(c_ptr), value :: dst, src
            integer(c_size_t), value :: nbytes
        end function cuda_update_device

        integer(c_int) function cuda_update_host( dst, src, nbytes) &
                                                bind(c, name="cuda_update_host")
            import :: c_ptr, c_size_t, c_int
            type(c_ptr), value :: dst, src
            integer(c_size_t), value :: nbytes
        end function cuda_update_host

        integer(c_int) function cuda_update_device_async( dst, src, nbytes) &
                                                bind(c, name="cuda_update_device_async")
            import :: c_ptr, c_size_t, c_int
            type(c_ptr), value :: dst, src
            integer(c_size_t), value :: nbytes
        end function cuda_update_device_async

        integer(c_int) function cuda_update_host_async( dst, src, nbytes) &
                                                bind(c, name="cuda_update_host_async")
            import :: c_ptr, c_size_t, c_int
            type(c_ptr), value :: dst, src
            integer(c_size_t), value :: nbytes
        end function cuda_update_host_async

        integer(c_int) function cuda_update_device_async_with_stream( dst, src, nbytes, astream) &
                                                bind(c, name="cuda_update_device_async_with_stream")
            import :: c_ptr, c_size_t, c_int
            type(c_ptr), value :: dst, src
            integer(c_size_t), value :: nbytes
            type(c_ptr), value :: astream
        end function cuda_update_device_async_with_stream

        integer(c_int) function cuda_update_host_async_with_stream( dst, src, nbytes, astream) &
                                                bind(c, name="cuda_update_host_async_with_stream")
            import :: c_ptr, c_size_t, c_int
            type(c_ptr), value :: dst, src
            integer(c_size_t), value :: nbytes
            type(c_ptr), value :: astream
        end function cuda_update_host_async_with_stream

        integer(c_int) function cuda_device2device( dst, src, nbytes) &
                                                bind(c, name="cuda_device2device")
            import :: c_ptr, c_size_t, c_int
            type(c_ptr), value :: dst, src
            integer(c_size_t), value :: nbytes
        end function cuda_device2device

        integer(c_int) function cuda_device2device_with_stream( dst, src, nbytes, astream) &
                                                bind(c, name="cuda_device2device_with_stream")
            import :: c_ptr, c_size_t, c_int
            type(c_ptr), value :: dst, src
            integer(c_size_t), value :: nbytes
            type(c_ptr), value :: astream
        end function cuda_device2device_with_stream

        integer(c_int) function cudamemgetinfo( free, total) &
                                                bind(c, name="cudaMemGetInfo")
            import :: c_size_t, c_int
            integer(c_size_t) :: free, total
        end function cudamemgetinfo
    end interface
end module cuda_data_wrapper_module

max_stars_repo_name: cheshyre/ntcl-data

max_issues_repo_name: cheshyre/ntcl-data

max_forks_repo_name: cheshyre/ntcl-data


text:
	SUBROUTINE HSCOLR  ( icolr, iret )
C************************************************************************
C* HSCOLR - UTF								*
C* 									*
C* This subroutine sets the color on a graphics device.			*
C* 									*
C* HSCOLR  ( ICOLR, IRET )						*
C* 									*
C* Input parameters:							*
C*	ICOLR		INTEGER		Color number			*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C**									*
C* Log:									*
C* S. Jacobs/GSC	 8/97	Copied for the UTF driver		*
C************************************************************************
	INCLUDE		'ERROR.PRM'
C------------------------------------------------------------------------
	iret = NORMAL
	CALL USCOLR ( icolr, iret )
C*
	RETURN
	END

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


text:
! Copyright 2005-2018 ECMWF.
!
! This software is licensed under the terms of the Apache Licence Version 2.0
! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0.
!
! In applying this licence, ECMWF does not waive the privileges and immunities granted to it by
! virtue of its status as an intergovernmental organisation nor does it submit to any jurisdiction.
!
!
!  Description: prints all the data contained in a GRIB file
!
!
!
program print_data
use eccodes
implicit none
integer            :: ifile
integer            :: iret
integer            :: igrib
integer            :: i
real(kind=8), dimension(:), allocatable       :: values
integer(kind=4)    :: numPoints
real(kind=8)       :: average
real(kind=8)       :: the_max
real(kind=8)       :: the_min

  call codes_open_file(ifile, &
           '../../data/constant_field.grib1','r')

  ! A new GRIB message is loaded from file
  ! igrib is the grib id to be used in subsequent calls
  call codes_grib_new_from_file(ifile,igrib)

  ! Get the size of the values array
  call codes_get_size(igrib,'values',numPoints)

  ! Get data values
  print*, 'number of points ', numPoints
  allocate(values(numPoints), stat=iret)

  call codes_get(igrib,'values',values)

  do i=1,numPoints
    write(*,*)'  ',i,values(i)
  enddo

  write(*,*)numPoints,' values found '

  call codes_get(igrib,'max',the_max)
  write(*,*) 'max=',the_max
  call codes_get(igrib,'min',the_min)
  write(*,*) 'min=',the_min
  call codes_get(igrib,'average',average)
  write(*,*) 'average=',average

  call codes_release(igrib)
  call codes_close_file(ifile)
  deallocate(values)

end program print_data

max_stars_repo_name: onyb/eccodes

max_issues_repo_name: onyb/eccodes

max_forks_repo_name: onyb/eccodes


MODULE trd_oce
  USE par_oce
  USE trdmxl_oce
  USE trdvor_oce
  IMPLICIT NONE
  PUBLIC
  LOGICAL, PUBLIC :: ln_dyn_trd = .FALSE.
  LOGICAL, PUBLIC :: ln_tra_trd = .FALSE.
  LOGICAL, PUBLIC :: ln_KE_trd = .FALSE.
  LOGICAL, PUBLIC :: ln_PE_trd = .FALSE.
  LOGICAL, PUBLIC :: ln_vor_trd = .FALSE.
  LOGICAL, PUBLIC :: ln_glo_trd = .FALSE.
  LOGICAL, PUBLIC :: ln_dyn_mxl = .FALSE.
  LOGICAL, PUBLIC :: ln_tra_mxl = .FALSE.
  INTEGER, PUBLIC :: nn_trd = 10
  LOGICAL, PUBLIC :: l_trdtra
  LOGICAL, PUBLIC :: l_trddyn
  LOGICAL, PUBLIC :: l_trdtrc = .FALSE.
  INTEGER, PUBLIC, PARAMETER :: jptot_tra = 20
  INTEGER, PUBLIC, PARAMETER :: jptra_xad = 1
  INTEGER, PUBLIC, PARAMETER :: jptra_yad = 2
  INTEGER, PUBLIC, PARAMETER :: jptra_zad = 3
  INTEGER, PUBLIC, PARAMETER :: jptra_sad = 4
  INTEGER, PUBLIC, PARAMETER :: jptra_totad = 5
  INTEGER, PUBLIC, PARAMETER :: jptra_ldf = 6
  INTEGER, PUBLIC, PARAMETER :: jptra_zdf = 7
  INTEGER, PUBLIC, PARAMETER :: jptra_zdfp = 8
  INTEGER, PUBLIC, PARAMETER :: jptra_evd = 9
  INTEGER, PUBLIC, PARAMETER :: jptra_bbc = 10
  INTEGER, PUBLIC, PARAMETER :: jptra_bbl = 11
  INTEGER, PUBLIC, PARAMETER :: jptra_npc = 12
  INTEGER, PUBLIC, PARAMETER :: jptra_dmp = 13
  INTEGER, PUBLIC, PARAMETER :: jptra_qsr = 14
  INTEGER, PUBLIC, PARAMETER :: jptra_nsr = 15
  INTEGER, PUBLIC, PARAMETER :: jptra_atf = 16
  INTEGER, PUBLIC, PARAMETER :: jptra_tot = 17
  INTEGER, PUBLIC, PARAMETER :: jptra_sms = 18
  INTEGER, PUBLIC, PARAMETER :: jptra_radn = 19
  INTEGER, PUBLIC, PARAMETER :: jptra_radb = 20
  INTEGER, PUBLIC, PARAMETER :: jptot_dyn = 13
  INTEGER, PUBLIC, PARAMETER :: jpdyn_hpg = 1
  INTEGER, PUBLIC, PARAMETER :: jpdyn_spg = 2
  INTEGER, PUBLIC, PARAMETER :: jpdyn_keg = 3
  INTEGER, PUBLIC, PARAMETER :: jpdyn_rvo = 4
  INTEGER, PUBLIC, PARAMETER :: jpdyn_pvo = 5
  INTEGER, PUBLIC, PARAMETER :: jpdyn_zad = 6
  INTEGER, PUBLIC, PARAMETER :: jpdyn_ldf = 7
  INTEGER, PUBLIC, PARAMETER :: jpdyn_zdf = 8
  INTEGER, PUBLIC, PARAMETER :: jpdyn_bfr = 9
  INTEGER, PUBLIC, PARAMETER :: jpdyn_atf = 10
  INTEGER, PUBLIC, PARAMETER :: jpdyn_tau = 11
  INTEGER, PUBLIC, PARAMETER :: jpdyn_bfri = 12
  INTEGER, PUBLIC, PARAMETER :: jpdyn_ken = 13
END MODULE trd_oce


text:
! <mod_depo.f90 - A component of the City-scale
!                 Chemistry Transport Model EPISODE-CityChem>
!*****************************************************************************!
!*
!* EPISODE - An urban-scale air quality model
!* ==========================================
!* Copyright (C) 2018  NILU - Norwegian Institute for Air Research
!*                     Instituttveien 18
!*                     PO Box 100
!*                     NO-2027 Kjeller
!*                     Norway
!*
!*                     Contact persons: Gabriela Sousa Santos - gss@nilu.no
!*                                      Paul Hamer - pdh@nilu.no
!*
!* Unless explicitly acquired and licensed from Licensor under another license,
!* the contents of this file are subject to the Reciprocal Public License ("RPL")
!* Version 1.5, https://opensource.org/licenses/RPL-1.5 or subsequent versions as
!* allowed by the RPL, and You may not copy or use this file in either source code
!* or executable form, except in compliance with the terms and conditions of the RPL.
!*
!* All software distributed under the RPL is provided strictly on an "AS IS" basis,
!* WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESS OR IMPLIED, AND LICENSOR HEREBY
!* DISCLAIMS ALL SUCH WARRANTIES, INCLUDING WITHOUT LIMITATION, ANY WARRANTIES OF
!* MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, QUIET ENJOYMENT, OR NON-INFRINGEMENT.
!* See the RPL for specific language governing rights and limitations under the RPL.
!*
!* ==========================================
!* The dispersion model EPISODE (Grønskei et. al., 1993; Larssen et al., 1994;
!* Walker et al., 1992, 1999; Slørdal et al., 2003, 2008) is an Eulerian grid model
!* with embedded subgrid models for calculations of pollutant concentrations resulting
!* from different types of sources (area-, line- and point sources). EPISODE solves the
!* time dependent advection/-diffusion equation on a 3 dimensional grid.
!* Finite difference numerical methods are applied to integrate the solution forward in time.
!* It also includes extensions as the implementation of a simplified EMEP photochemistry
!* scheme for urban areas (Walker et al. 2004) and a scheme for Secondary Organic Aerosol
!* implemented by Håvard Slørdal
!*
!* Grønskei, K.E., Walker, S.E., Gram, F. (1993) Evaluation of a model for hourly spatial
!*    concentrations distributions. Atmos. Environ., 27B, 105-120.
!* Larssen, S., Grønskei, K.E., Gram, F., Hagen, L.O., Walker, S.E. (1994) Verification of
!*    urban scale time-dependent dispersion model with sub-grid elements in Oslo, Norway.
!*    In: Air poll. modelling and its appl. X. New York, Plenum Press.
!* Slørdal, L.H., McInnes, H., Krognes, T. (2008): The Air Quality Information System AirQUIS.
!*    Info. Techn. Environ. Eng., 1, 40-47, 2008.
!* Slørdal, L.H., Walker, S.-E., Solberg, S. (2003) The Urban Air Dispersion Model EPISODE
!*    applied in AirQUIS. Technical Description. NILU TR 12/2003. ISBN 82-425-1522-0.
!* Walker, S.E., Grønskei, K.E. (1992) Spredningsberegninger for on-line overvåking i Grenland.
!*    Programbeskrivelse og brukerveiledning. Lillestrøm,
!*    Norwegian Institute for Air Research (NILU OR 55/92).
!* Walker, S.E., Slørdal, L.H., Guerreiro, C., Gram, F., Grønskei, K.E. (1999) Air pollution
!*    exposure monitoring and estimation. Part II. Model evaluation and population exposure.
!*    J. Environ. Monit, 1, 321-326.
!* Walker, S.-E., Solberg, S., Denby, B. (2003) Development and implementation of a
!*    simplified EMEP photochemistry scheme for urban areas in EPISODE. NILU TR 13/2013.
!*    ISBN 82-425-1524-7
!*****************************************************************************!

      module mod_depo

! ----------------------------------------------------------------------------------
! Based on:
! Version Episode 5.5 (May29, 2012) prepared for BB-Stand-Alone
! Original source code of EPISODE by Sam-Erik Walker (NILU)
!
! Sam-Erik Walker
! Norwegian Institute for Air Research (NILU)
! Instituttveien 18 P.O. Box 100
! N-2027 Kjeller, NORWAY
! Tel: +47 63898000 Fax: +47 63898050
! E-mail: sam-erik.walker@nilu.no
!
! ----------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------
! REVISION HISTORY
!
!    xx Dat 201x  Name: Line  Description of Change
!
! ----------------------------------------------------------------------------------

      character(len=256)             :: ddeplfn
      character(len=256),allocatable :: ddepmfn(:)
      character(len=256)             :: ddeprfn
      character(len=256),allocatable :: ddepsfn(:)
      character(len=256)             :: wdeplfn
      character(len=256),allocatable :: wdepmfn(:)
      character(len=256)             :: wdeprfn
      character(len=256),allocatable :: wdepsfn(:)

! ddeplfn - Line sources dry depositions file name
! ddepmfn - Main grid    dry depositions file name (nc)
! ddeprfn - Receptors    dry depositions file name
! ddepsfn - Sub  grid    dry depositions file name (nc)
! wdeplfn - Line sources wet depositions file name
! wdepmfn - Main grid    wet depositions file name (nc)
! wdeprfn - Receptors    wet depositions file name
! wdepsfn - Sub  grid    wet depositions file name (nc)

      integer             :: ddeplun
      integer,allocatable :: ddepmun(:)
      integer             :: ddeprun
      integer,allocatable :: ddepsun(:)
      integer             :: wdeplun
      integer,allocatable :: wdepmun(:)
      integer             :: wdeprun
      integer,allocatable :: wdepsun(:)

! ddeplun - Line sources dry depositions fileunit
! ddepmun - Main grid    dry depositions fileunit (nc)
! ddeprun - Receptors    dry depositions fileunit
! ddepsun - Sub  grid    dry depositions fileunit (nc)
! wdeplun - Line sources wet depositions fileunit
! wdepmun - Main grid    wet depositions fileunit (nc)
! wdeprun - Receptors    wet depositions fileunit
! wdepsun - Sub  grid    wet depositions fileunit (nc)

      logical             :: ddeplfe
      logical,allocatable :: ddepmfe(:)
      logical             :: ddeprfe
      logical,allocatable :: ddepsfe(:)
      logical             :: wdeplfe
      logical,allocatable :: wdepmfe(:)
      logical             :: wdeprfe
      logical,allocatable :: wdepsfe(:)

! ddeplfe - Line sources dry depositions file exists
! ddepmfe - Main grid    dry depositions file exists (nc)
! ddeprfe - Receptors    dry depositions file exists
! ddepsfe - Sub  grid    dry depositions file exists (nc)
! wdeplfe - Line sources wet depositions file exists
! wdepmfe - Main grid    wet depositions file exists (nc)
! wdeprfe - Receptors    wet depositions file exists
! wdepsfe - Sub  grid    wet depositions file exists (nc)

      real             :: ddeplfv(1)
      real,allocatable :: ddepmfv(:)
      real             :: ddeprfv(1)
      real,allocatable :: ddepsfv(:)
      real             :: wdeplfv(1)
      real,allocatable :: wdepmfv(:)
      real             :: wdeprfv(1)
      real,allocatable :: wdepsfv(:)

! ddeplfv - Line sources dry depositions file value
! ddepmfv - Main grid    dry depositions file value (nc)
! ddeprfv - Receptors    dry depositions file value
! ddepsfv - Sub  grid    dry depositions file value (nc)
! wdeplfv - Line sources wet depositions file value
! wdepmfv - Main grid    wet depositions file value (nc)
! wdeprfv - Receptors    wet depositions file value
! wdepsfv - Sub  grid    wet depositions file value (nc)

      integer             :: ddeplfm
      integer,allocatable :: ddepmfm(:)
      integer             :: ddeprfm
      integer,allocatable :: ddepsfm(:)
      integer             :: wdeplfm
      integer,allocatable :: wdepmfm(:)
      integer             :: wdeprfm
      integer,allocatable :: wdepsfm(:)

! ddeplfm - Line sources dry depositions file format (index)
! ddepmdm - Main grid    dry depositions file format (index) (nc)
! ddeprfm - Receptors    dry depositions file format (index)
! ddepsfm - Sub  grid    dry depositions file format (index) (nc)
! wdeplfm - Line sources wet depositions file format (index)
! wdepmfm - Main grid    wet depositions file format (index) (nc)
! wdeprfm - Receptors    wet depositions file format (index)
! wdepsfm - Sub  grid    wet depositions file format (index) (nc)

      integer,allocatable :: ddepoi(:)
      integer,allocatable :: wdepoi(:)

! ddepoi - Dry deposition output indicator (nc)
! wdepoi - Wet deposition output indicator (nc)

      real,allocatable :: ddepv(:)
      real,allocatable :: wdepsr(:)

! ddepv  - Dry deposition velocities (nc)
! wdepsr - Wet deposition scavenging ratio (nc)

      real,allocatable :: ddepm(:,:,:)
      real,allocatable :: ddepr(:,:)
      real,allocatable :: ddeps(:,:,:,:)
      real,allocatable :: wdepm(:,:,:)
      real,allocatable :: wdepr(:,:)
      real,allocatable :: wdeps(:,:,:,:)

! ddepm - Main grid dry depositions field (nx,ny,nc)
! ddepr - Receptors dry depositions values (nc,nr)
! ddeps - Sub  grid dry depositions field (nc,nxs,nys,nls)
! wdepm - Main grid wet depositions field (nx,ny,nc)
! wdepr - Receptors wet depositions values (nc,nr)
! wdeps - Sub  grid wet depositions field (nc,nxs,nys,nls)

!_LHS_08_Oct_2004_Start:
!_Deposition:
!
!    The Dry-Deposition velocities above are defined as a constant for
!    each compound. For a more general treatment we need to define
!    spatially variable  (2-dimensional) values.
!    Is this necessary for the wet scavenging ratios ???

      real,allocatable :: ddepv2d(:,:,:)
      real,allocatable :: wdeprate2d(:,:,:)

! ddepv2d    - Two-dimensional Dry-Deposition velocities (nc,nx,ny)
! wdeprate2d  - Two-dimensional Wet-Deposition velocities (nc,nx,ny)
!
!_LHS_08_Oct_2004_End.

!_LHS_EIFAir_change_Start:
      real,allocatable :: ddeprl(:,:)
      real,allocatable :: wdeprl(:,:)

! ddeprl - Line sources receptor points dry depositions (nc,nrl)
! wdeprl - Line sources receptor points wet depositions (nc,nrl)
!_LHS_EIFAir_change_End.

      contains

      subroutine FreeDepoMemory()

!DEC$ ATTRIBUTES DLLEXPORT,STDCALL,ALIAS:'FreeDepoMemory' :: FreeDepoMemory

      implicit none

      if (allocated(ddepmfn)) deallocate(ddepmfn)
      if (allocated(ddepsfn)) deallocate(ddepsfn)
      if (allocated(wdepmfn)) deallocate(wdepmfn)
      if (allocated(wdepsfn)) deallocate(wdepsfn)
      if (allocated(ddepmun)) deallocate(ddepmun)
      if (allocated(ddepsun)) deallocate(ddepsun)
      if (allocated(wdepmun)) deallocate(wdepmun)
      if (allocated(wdepsun)) deallocate(wdepsun)
      if (allocated(ddepmfe)) deallocate(ddepmfe)
      if (allocated(ddepsfe)) deallocate(ddepsfe)
      if (allocated(wdepmfe)) deallocate(wdepmfe)
      if (allocated(wdepsfe)) deallocate(wdepsfe)
      if (allocated(ddepmfv)) deallocate(ddepmfv)
      if (allocated(ddepsfv)) deallocate(ddepsfv)
      if (allocated(wdepmfv)) deallocate(wdepmfv)
      if (allocated(wdepsfv)) deallocate(wdepsfv)
      if (allocated(ddepmfm)) deallocate(ddepmfm)
      if (allocated(ddepsfm)) deallocate(ddepsfm)
      if (allocated(wdepmfm)) deallocate(wdepmfm)
      if (allocated(wdepsfm)) deallocate(wdepsfm)
      if (allocated(ddepoi))  deallocate(ddepoi)
      if (allocated(wdepoi))  deallocate(wdepoi)
      if (allocated(ddepv))   deallocate(ddepv)
      if (allocated(wdepsr))  deallocate(wdepsr)
      if (allocated(ddepm))   deallocate(ddepm)
      if (allocated(wdepm))   deallocate(wdepm)
      if (allocated(ddepr))   deallocate(ddepr)
      if (allocated(wdepr))   deallocate(wdepr)
      if (allocated(ddeps))   deallocate(ddeps)
      if (allocated(wdeps))   deallocate(wdeps)
!_LHS_08_Oct_2004_Start.
      if (allocated(ddepv2d))     deallocate(ddepv2d)
      if (allocated(wdeprate2d))   deallocate(wdeprate2d)
!_LHS_08_Oct_2004_End.
!_LHS_EIFAir_change_Start:
      if (allocated(ddeprl))  deallocate(ddeprl)
      if (allocated(wdeprl))  deallocate(wdeprl)
!_LHS_EIFAir_change_End.

      ddeplfn = ' '
      ddeprfn = ' '
      wdeplfn = ' '
      wdeprfn = ' '
      ddeplun = 0
      ddeprun = 0
      wdeplun = 0
      wdeprun = 0
      ddeplfe = .false.
      ddeprfe = .false.
      wdeplfe = .false.
      wdeprfe = .false.
      ddeplfv = 0.
      ddeprfv = 0.
      wdeplfv = 0.
      wdeprfv = 0.
      ddeplfm = 0
      ddeprfm = 0
      wdeplfm = 0
      wdeprfm = 0

! End of subroutine FreeDepoMemory

      end subroutine

      end module mod_depo

max_stars_repo_name: mdhillmancmcl/TheWorldAvatar-CMCL-Fork

max_issues_repo_name: mdhillmancmcl/TheWorldAvatar-CMCL-Fork

max_forks_repo_name: mdhillmancmcl/TheWorldAvatar-CMCL-Fork


text: #redirect Wood Sorrel

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search