text:
!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2019 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine tiefaccont(lakon,ipkon,kon,ntie,tieset,nset,set,
     &  istartset,iendset,ialset,itiefac,islavsurf,islavnode,
     &  imastnode,nslavnode,nmastnode,nslavs,nmasts,ifacecount,
     &  iponoels,inoels,ifreenoels,mortar,ipoface,nodface,nk,xnoels)
!
!     Catalogueing the slave faces (itieface, islavsurf)
!                  the slave nodes (islavnode, nslavnode)
!                  the slave faces to which the slave nodes
!                       belong
!                  the master nodes (imastnode, nmastnode; only
!                       for surface-to-surface contact)
!
!     Authors: Li,Yang; Rakotonanahary, Samoela;
!
      implicit none
!
      logical nodeslavsurf
!
      character*8 lakon(*)
      character*81 tieset(3,*),slavset,mastset,set(*)
!
      logical exist
!
      integer ntie,i,j,k,l,nset,istartset(*),iendset(*),ialset(*),
     &  ifaces,nelems,jfaces,ifacem,nelemm,nslavs,nmasts,jface,
     &  jfacem,indexe,nopes,nopem,ipkon(*),kon(*),id,nodef(9),
     &  ifaceq(8,6),ifacet(6,4),ifacew1(4,5),ifacew2(8,5),node,
     &  itiefac(2,*),islavsurf(2,*),islavnode(*),imastnode(*),
     &  nslavnode(ntie+1),nmastnode(ntie+1),ifacecount,islav,imast,
     &  ipos,index1,iponoels(*),inoels(2,*),ifreenoels,ifreenoelold,
     &  mortar,numbern,numberf,iface,kflag,nk,ipoface(*),
     &  nodface(5,*),nface,nelem,nope
!
      real*8 xnoels(*)
!
! nslavnode: num of slave nodes
! islavnode: all slave nodes, tie by tie, ordered within one tie constraint
! nmastnode: num of master nodes
! imastnode: all master nodes, tie by tie, ordered within one tie constraint
! islavsurf: all slave faces
! itiefac: pointer into field islavsurf
!
!     nodes per face for hex elements
!
      data ifaceq /4,3,2,1,11,10,9,12,
     &            5,6,7,8,13,14,15,16,
     &            1,2,6,5,9,18,13,17,
     &            2,3,7,6,10,19,14,18,
     &            3,4,8,7,11,20,15,19,
     &            4,1,5,8,12,17,16,20/
!
!     nodes per face for tet elements
!
      data ifacet /1,3,2,7,6,5,
     &             1,2,4,5,9,8,
     &             2,3,4,6,10,9,
     &             1,4,3,8,10,7/
!
!     nodes per face for linear wedge elements
!
      data ifacew1 /1,3,2,0,
     &             4,5,6,0,
     &             1,2,5,4,
     &             2,3,6,5,
     &             3,1,4,6/
!
!     nodes per face for quadratic wedge elements
!
      data ifacew2 /1,3,2,9,8,7,0,0,
     &             4,5,6,10,11,12,0,0,
     &             1,2,5,4,7,14,10,13,
     &             2,3,6,5,8,15,11,14,
     &             3,1,4,6,9,13,12,15/
!
      ifacecount=0
      nslavs=0
      nmasts=0
      ifreenoels=0
      nodeslavsurf=.false.
!
!     counters for new fields islavsurf and itiefac
!
      do i=1,ntie
!
!        check for contact conditions
!
         if((tieset(1,i)(81:81).eq.'C').or.
     &      (tieset(1,i)(81:81).eq.'-')) then
            slavset=tieset(2,i)
!
!           check whether facial slave surface;
!
            ipos=index(slavset,' ')-1
!
!           default for node-to-surface contact is
!           a nodal slave surface
!
            if(slavset(ipos:ipos).eq.'S') then
               nodeslavsurf=.true.
            endif
!
!           determining the slave surface
!
            do j=1,nset
               if(set(j).eq.slavset) exit
            enddo
            if(j.gt.nset) then
               do j=1,nset
                  if((set(j)(1:ipos-1).eq.slavset(1:ipos-1)).and.
     &                 (set(j)(ipos:ipos).eq.'T')) then
                     nodeslavsurf=.false.
                     exit
                  endif
               enddo
            endif
!
            islav=j
!
            if((mortar.eq.0).and.(nodeslavsurf)) then
!
!           nodal slave surface and node-to-surface contact
!
!           storing the slave nodes in islavnode (sorted)
!
               nslavnode(i)=nslavs
               numbern=0
               do j=istartset(islav),iendset(islav)
                  if(ialset(j).gt.0) then
                     k=ialset(j)
                     call nident(islavnode(nslavs+1),k,numbern,id)
                     if(id.gt.0) then
                        if(islavnode(nslavs+id).eq.k) cycle
                     endif
                     numbern=numbern+1
                     do l=numbern,id+2,-1
                        islavnode(nslavs+l)=islavnode(nslavs+l-1)
                     enddo
                     islavnode(nslavs+id+1)=k
                  else
                     k=ialset(j-2)
                     do
                        k=k-ialset(j)
                        if(k.ge.ialset(j-1)) exit
                        call nident(islavnode(nslavs+1),k,numbern,id)
                        if(id.gt.0) then
                           if(islavnode(nslavs+id).eq.k) cycle
                        endif
                        numbern=numbern+1
                        do l=numbern,id+2,-1
                           islavnode(nslavs+l)=islavnode(nslavs+l-1)
                        enddo
                        islavnode(nslavs+id+1)=k
                     enddo
                  endif
                  nslavnode(i+1)=nslavnode(i)+numbern
               enddo
!
!              check all external solid faces whether they contain
!              slave nodes
!
!              islavsurf(1,*) contains the faces (ordered)
!              islavsurf(2,*) contains the position of the
!              original order
!
               itiefac(1,i)=ifacecount+1
               numberf=0
!
               do j=1,nk
                  index1=ipoface(j)
                  do
                     if(index1.eq.0) exit
                     iface=nodface(4,index1)
                     do k=0,3
                        if(k.eq.0) then
                           node=j
                        else
                           node=nodface(k,index1)
                        endif
!
!                       check whether node belongs to slave surface
!
                        call nident(islavnode(nslavs+1),node,numbern,
     &                                id)
                        if(id.gt.0) then
                           if(islavnode(nslavs+id).eq.node) then
                              call nident2(islavsurf(1,ifacecount+1),
     &                             iface,numberf,id)
!
                              ipos=0
                              if(id.gt.0) then
                                 if(islavsurf(1,ifacecount+id).eq.iface)
     &                              then
!                                   original position (not ordered)
                                    ipos=islavsurf(2,ifacecount+id)
                                 endif
                              endif
!
!                             check whether new face
!
                              if(ipos.eq.0) then
                                 numberf=numberf+1
                                 do l=ifacecount+numberf,ifacecount+id+2
     &                                      ,-1
                                    islavsurf(1,l)=islavsurf(1,l-1)
                                    islavsurf(2,l)=islavsurf(2,l-1)
                                 enddo
                                 islavsurf(1,ifacecount+id+1)=iface
                                 islavsurf(2,ifacecount+id+1)=numberf
!                                   original position (not ordered)
                                 ipos=numberf
                              endif
!
!                             update info to which faces a slave node
!                             belongs
!
                              ifreenoelold=iponoels(node)
                              ifreenoels=ifreenoels+1
                              iponoels(node)=ifreenoels
                              inoels(1,ifreenoels)=ifacecount+ipos
!
!                             determining the area coefficient (= the
!                             force coefficient corresponding to a
!                             uniform pressure on the face)
!
                              nelem=int(iface/10.d0)
                              jface=iface-10*nelem
!
                              indexe=ipkon(nelem)
                              if(lakon(nelem)(4:4).eq.'2') then
                                 nopes=8
                                 nface=6
                              elseif(lakon(nelem)(4:4).eq.'8') then
                                 nopes=4
                                 nface=6
                              elseif(lakon(nelem)(4:5).eq.'10') then
                                 nopes=6
                                 nface=4
                              elseif(lakon(nelem)(4:4).eq.'4') then
                                 nopes=3
                                 nface=4
                              elseif(lakon(nelem)(4:5).eq.'15') then
                                 if(jface.le.2) then
                                    nopes=6
                                 else
                                    nopes=8
                                 endif
                                 nface=5
                                 nope=15
                              elseif(lakon(nelem)(4:4).eq.'6') then
                                 if(jface.le.2) then
                                    nopes=3
                                 else
                                    nopes=4
                                 endif
                                 nface=5
                                 nope=6
                              else
                                 cycle
                              endif
!
!     determining the nodes of the face
!
                              if(nface.eq.4) then
                                 do l=1,nopes
                                    nodef(l)=kon(indexe+ifacet(l,jface))
                                    if(nodef(l).eq.node) then
                                       if(nopes.eq.3) then
                                          xnoels(ifreenoels)=1.d0/3.d0
!
!        for 6-node faces the weights 0 and 1/3 are changed into
!        1/999 and 332/999 in order to avoid problems with the
!        zero-area-check in springforc_n2f*f and springstiff_n2f*f
!
                                       elseif(l.le.3) then
                                          xnoels(ifreenoels)=1.d0/999.d0
                                       else
                                          xnoels(ifreenoels)
     &                                         =332.d0/999.d0
                                       endif
                                    endif
                                 enddo
                              elseif(nface.eq.5) then
                                 if(nope.eq.6) then
                                    do l=1,nopes
                                       nodef(l)=
     &                                    kon(indexe+ifacew1(l,jface))
                                       if(nodef(l).eq.node) then
                                          if(nopes.eq.3) then
                                            xnoels(ifreenoels)=1.d0/3.d0
                                          else
                                            xnoels(ifreenoels)=1.d0/4.d0
                                          endif
                                       endif
                                    enddo
                                 elseif(nope.eq.15) then
                                    do l=1,nopes
                                       nodef(l)=
     &                                    kon(indexe+ifacew2(l,jface))
                                       if(nodef(l).eq.node) then
                                          if(nopes.eq.6) then
                                             if(l.le.3) then
                                                xnoels(ifreenoels)=
     &                                               1.d0/999.d0
                                             else
                                                xnoels(ifreenoels)=
     &                                               332.d0/999.d0
                                             endif
                                          else
!
!           for a 8-node face a distribution of 1/100 at the vertex
!           nodes and 24/100 at the midnodes (instead of -1/12 and 1/3)
!
                                             if(l.le.4) then
                                                xnoels(ifreenoels)=
     &                                                   1.d0/100.d0
                                             else
                                                xnoels(ifreenoels)=
     &                                                   24.d0/100.d0
                                             endif
                                          endif
                                       endif
                                    enddo
                                 endif
                              elseif(nface.eq.6) then
                                 do l=1,nopes
                                    nodef(l)=kon(indexe+ifaceq(l,jface))
                                    if(nodef(l).eq.node) then
                                       if(nopes.eq.4) then
                                          xnoels(ifreenoels)=1.d0/4.d0
!
!           for a 8-node face a distribution of 1/100 at the vertex
!           nodes and 24/100 at the midnodes (instead of -1/12 and 1/3)
!
                                       elseif(l.le.4) then
                                          xnoels(ifreenoels)=1.d0/100.d0
                                       else
                                          xnoels(ifreenoels)=
     &                                            24.d0/100.d0
                                       endif

                                    endif
                                 enddo
                              endif
!
                              inoels(2,ifreenoels)=ifreenoelold
                           endif
                        endif
                     enddo
                     index1=nodface(5,index1)
                  enddo
               enddo
!
!           restoring the right order of islavsurf(1,*);
!           thereafter islavsurf(2,*) is obsolete for node-to-surface
!           contact
!
               kflag=2
               call isorti(islavsurf(1,ifacecount+1),numberf,kflag)
!
!              update ifacecount and itiefac
!
               itiefac(2,i)=ifacecount+numberf
!
               nslavs=nslavnode(i+1)
               ifacecount=itiefac(2,i)
!
            else
!
!           element face slave surface (node-to-surface or
!           surface-to-surface contact)
!
            nslavnode(i)=nslavs
!
            itiefac(1,i)=ifacecount+1
            do j=istartset(islav),iendset(islav)
               if(ialset(j).gt.0) then
!
!                store the slave face in islavsurf
!
                  ifacecount=ifacecount+1
                  islavsurf(1,ifacecount)=ialset(j)
!
!                 store the nodes belonging to the slave face
!                 in islavnode
!
                  ifaces=ialset(j)
                  nelems=int(ifaces/10)
                  jfaces=ifaces - nelems*10
                  indexe=ipkon(nelems)
!
                  if(lakon(nelems)(4:5).eq.'20') then
                      nopes=8
                  elseif(lakon(nelems)(4:4).eq.'8') then
                      nopes=4
                  elseif(lakon(nelems)(4:5).eq.'10') then
                      nopes=6
                  elseif(lakon(nelems)(4:4).eq.'4') then
                      nopes=3
                  endif
!
                  if(lakon(nelems)(4:4).eq.'6') then
                    if(jfaces.le.2) then
                       nopes=3
                    else
                       nopes=4
                    endif
                  endif
                  if(lakon(nelems)(4:5).eq.'15') then
                    if(jfaces.le.2) then
                       nopes=6
                    else
                       nopes=8
                    endif
                  endif
!
                  do l=1,nopes
                     if((lakon(nelems)(4:4).eq.'2').or.
     &                  (lakon(nelems)(4:4).eq.'8')) then
                        node=kon(indexe+ifaceq(l,jfaces))
                     elseif((lakon(nelems)(4:4).eq.'4').or.
     &                      (lakon(nelems)(4:5).eq.'10')) then
                        node=kon(indexe+ifacet(l,jfaces))
                     elseif(lakon(nelems)(4:4).eq.'6') then
                        node=kon(indexe+ifacew1(l,jfaces))
                     elseif(lakon(nelems)(4:5).eq.'15') then
                        node=kon(indexe+ifacew2(l,jfaces))
                     endif
                     call nident(islavnode(nslavnode(i)+1),node,
     &                    nslavs-nslavnode(i),id)
                     exist=.FALSE.
                     if(id.gt.0) then
                        if(islavnode(nslavnode(i)+id).eq.node) then
                           exist=.TRUE.
                        endif
                     endif
                     if(.not.exist) then
                        nslavs=nslavs+1
                        do k=nslavs,nslavnode(i)+id+2,-1
                           islavnode(k)=islavnode(k-1)
                        enddo
                        islavnode(nslavnode(i)+id+1)=node
                     endif
!
!                    filling fields iponoels and inoels
!
                     if(mortar.eq.0) then
c                        ifreenoelold=iponoels(node)
                        ifreenoels=ifreenoels+1
c                        iponoels(node)=ifreenoels
                        inoels(1,ifreenoels)=ifacecount
                        inoels(2,ifreenoels)=iponoels(node)
                        iponoels(node)=ifreenoels
!
!     filling xnoels with the coefficient corresponding
!     to a constant pressure (sum over all nodes must
!     be 1)
!
                        if(nopes.eq.3) then
                           xnoels(ifreenoels)=1.d0/3.d0
                        elseif(nopes.eq.4) then
                           xnoels(ifreenoels)=1.d0/4.d0
                        elseif(nopes.eq.6) then
                           if(l.le.3) then
                              xnoels(ifreenoels)=1.d0/999.d0
                           else
                              xnoels(ifreenoels)=332.d0/999.d0
                           endif
                        elseif(nopes.eq.8) then
!
!     for a 8-node face a distribution of 1/100 at the vertex
!     nodes and 24/100 at the midnodes (instead of -1/12 and 1/3)
!
                           if(l.le.4) then
                              xnoels(ifreenoels)=1.d0/100.d0
                           else
                              xnoels(ifreenoels)=24.d0/100.d0
                           endif
                        endif
c                        inoels(2,ifreenoels)=ifreenoelold
                     endif
                  enddo
!
               endif
            enddo
            nslavnode(i+1)=nslavs
            itiefac(2,i)=ifacecount
            endif
!
!           determining the master surface
!
            mastset=tieset(3,i)
            do j=1,nset
               if(set(j).eq.mastset) exit
            enddo
            if(j.gt.nset) then
               write(*,*) '*ERROR in tiefaccont: master surface'
               write(*,*) '       does not exist'
               call exit(201)
            endif
            imast=j
            nmastnode(i)=nmasts
!
            do j=istartset(imast),iendset(imast)
!
!              create imastnode, and nmastnode
!
               ifacem=ialset(j)
               nelemm=int(ifacem/10)
               jfacem=ifacem - nelemm*10
               indexe=ipkon(nelemm)
!
               if(lakon(nelemm)(4:5).eq.'20') then
                  nopem=8
               elseif(lakon(nelemm)(4:4).eq.'8') then
                  nopem=4
               elseif(lakon(nelemm)(4:5).eq.'10') then
                  nopem=6
               elseif(lakon(nelemm)(4:4).eq.'4') then
                  nopem=3
               endif
!
               if(lakon(nelemm)(4:4).eq.'6') then
                  if(jfacem.le.2) then
                     nopem=3
                  else
                     nopem=4
                  endif
               endif
               if(lakon(nelemm)(4:5).eq.'15') then
                  if(jfacem.le.2) then
                     nopem=6
                  else
                     nopem=8
                  endif
               endif
!
               do l=1,nopem
                  if((lakon(nelemm)(4:4).eq.'2').or.
     &                 (lakon(nelemm)(4:4).eq.'8')) then
                     node=kon(indexe+ifaceq(l,jfacem))
                  elseif((lakon(nelemm)(4:4).eq.'4').or.
     &                    (lakon(nelemm)(4:5).eq.'10')) then
                     node=kon(indexe+ifacet(l,jfacem))
                  elseif(lakon(nelemm)(4:4).eq.'6') then
                     node=kon(indexe+ifacew1(l,jfacem))
                  elseif(lakon(nelemm)(4:5).eq.'15') then
                     node=kon(indexe+ifacew2(l,jfacem))
                  endif
                  call nident(imastnode(nmastnode(i)+1),node,
     &                 nmasts-nmastnode(i),id)
                  exist=.FALSE.
                  if(id.gt.0) then
                     if(imastnode(nmastnode(i)+id).eq.node) then
                        exist=.TRUE.
                     endif
                  endif
                  if(exist) cycle
                  nmasts=nmasts+1
                  do k=nmasts,nmastnode(i)+id+2,-1
                     imastnode(k)=imastnode(k-1)
                  enddo
                  imastnode(nmastnode(i)+id+1)=node
               enddo
!
            enddo
            nmastnode(i+1)=nmasts
!
         else
!
!           no contact tie
!
            nslavnode(i+1)=nslavnode(i)
c            if(mortar.eq.1) nmastnode(i+1)=nmastnode(i)
            nmastnode(i+1)=nmastnode(i)
         endif
      enddo
!
      return
      end

max_stars_repo_name: alleindrach/calculix-desktop

max_issues_repo_name: alleindrach/calculix-desktop

max_forks_repo_name: alleindrach/calculix-desktop


text:
\ REGISTERS GPIO

FE000000 CONSTANT PERI_BASE
PERI_BASE 200000 + CONSTANT GPIO_BASE
PERI_BASE 804000 + CONSTANT I2C_BASE_REGISTER
GPIO_BASE 	CONSTANT GPFSEL0

: REGISTERS_I2C{ \ ( -- ADDR )
  I2C_BASE_REGISTER ;

: REGISTER ( ADDR -- ADDR )
  DUP 4 + SWAP CONSTANT ;

: }REGISTERS_I2C ( ADDR -- )
  DROP ;

REGISTERS_I2C{
  REGISTER I2C_CONTROL
  REGISTER I2C_STATUS
  REGISTER I2C_DLEN
  REGISTER I2C_SLAVE_REGISTER
  REGISTER I2C_FIFO
  REGISTER I2C_CLOCK_DIVIDER
  REGISTER I2C_DATA_DELAY
  REGISTER I2C_CLOCK_STRETCH_TIMEOUT
}REGISTERS_I2C

\ CONTROL_REGISTER

\ ENABLE/DISABLE I2C
: I2C ( FLAG -- )
  I2C_CONTROL F SET_BIT ;

\ START_TRANSFER
: ST ( -- )
  1 I2C_CONTROL 7 SET_BIT ;

\ CLEAR_FIFO
: CLEAR ( -- )
  1 I2C_CONTROL 4 SET_BIT ;

\ READ_TRANSFER
: R_BIT ( -- )
  1 I2C_CONTROL 0 SET_BIT ;

\ WRITE_TRANSFER
: W_BIT ( -- )
  0 I2C_CONTROL 0 SET_BIT ;

\ INTERRUPT_RX
: INTR ( FLAG -- )
  I2C_CONTROL A SET_BIT ; \ ENABLE/DISABLE INTERRUPTS ON RX

\ INTERRUPT_TX
: INTT ( FLAG -- )
  I2C_CONTROL 9 SET_BIT ; \ ENABLE/DISABLE INTERRUPTS ON TX

\ INTERRUPT_DONE
: INTD ( FLAG -- )
  I2C_CONTROL 8 SET_BIT ; \ ENABLE/DISABLE INTERRUPTS ON DONE

\ STATUS

\ USE GET_BIT FOR READING THE BIT'S VALUE

\ CLOCK_STRETCH_TIMEOUT
: CLKT ( -- REGISTER BIT_POSITION )
  I2C_STATUS 9 ;

\ ACK ERROR
: ERR ( -- REGISTER BIT_POSITION )
  I2C_STATUS 8 ;

\ FIFO FULL
: RXF ( -- REGISTER BIT_POSITION )
  I2C_STATUS 7 ;

\ FIFO EMPTY
: TXE ( -- REGISTER BIT_POSITION )
  I2C_STATUS 6 ;

\ FIFO CONTAINS DATA
: RXD ( -- REGISTER BIT_POSITION )
  I2C_STATUS 5 ;

\ FIFO CAN ACCEPT DATA
: TXD ( -- REGISTER BIT_POSITION )
  I2C_STATUS 4 ;

\ FIFO NEEDS READING
: RXR ( -- REGISTER BIT_POSITION )
  I2C_STATUS 3 ;

\ FIFO NEEDS WRITING
: TXW ( -- REGISTER BIT_POSITION )
  I2C_STATUS 2 ;

\ TRANSFER DONE
: DONE ( -- REGISTER BIT_POSITION )
  I2C_STATUS 1 ;

\ TRANSFER ACTIVE
: TA ( -- REGISTER BIT_POSITION )
  I2C_STATUS 0 ;

: RESET ( REGISTER BIT_POSITION -- )
  1 -ROT SET_BIT ;

\ FIFO
\ FOR SETTING ( VALUE DATA SET ) FOR GETTING ( DATA GET )
: DATA ( -- REGISTER BIT_POSITION_INITIAL BIT_POSITION_FINAL )
  I2C_FIFO 0 7 ;

\ SETTING ALTERNATE FUNCTIONS AND ENABLE I2C
: I2C_INIT
  GPFSEL0 DUP @ FC0 INVERT AND 900 OR SWAP !
  ENABLE I2C ;

\ I2C USAGE

\ CHECK IF THE TRANSFER IS DONE CORRECTLY ( DONE==1 TA==0 ERR==0)
: ?CHECK ( -- FLAG )
  DONE GET_BIT TA GET_BIT 0= ERR GET_BIT 0= AND AND ;

: I2C_WRITE ( VALUES SLAVE_ADDRESS #BYTES -- )
  DONE RESET \ RESET DONE
  CLEAR \ CLEAR FIFO
  DUP >R \ DUPLICATE #BYTES ONTO RETURN STACK
  I2C_DLEN ! \ SET #BYTES
  I2C_SLAVE_REGISTER ! \ SET SLAVE ADDRESS
  W_BIT \ SET WRITING
  R>
  BEGIN
    1- SWAP DATA SET DUP 0= \ SET FIFO
  UNTIL DROP
  ST \ START WRITING
  BEGIN
    ?CHECK \ WAIT UNTIL THE CORRECT WRITING
  UNTIL ;

: I2C_READ ( SLAVE_ADDRESS #BYTES -- VALUES )
  DONE RESET \ RESET DONE
  DUP >R \ DUPLICATE #BYTES ONTO THE RETURN STACK
  I2C_DLEN ! \ SET #BYTES
  I2C_SLAVE_REGISTER ! \ SET SLAVE ADDRESS
  R_BIT \ SET READING
  ST  \ START READING
  BEGIN
    ?CHECK \ WAIT UNTIL THE CORRECT READING
  UNTIL
  R>
  BEGIN
    1- DATA GET SWAP DUP 0= \ PUSH DATA ONTO THE STACK
  UNTIL DROP ;

ext: f


text:
-makelib xcelium_lib/xpm -sv \
  "C:/Xilinx/Vivado/2020.2/data/ip/xpm/xpm_memory/hdl/xpm_memory.sv" \
-endlib
-makelib xcelium_lib/xpm \
  "C:/Xilinx/Vivado/2020.2/data/ip/xpm/xpm_VCOMP.vhd" \
-endlib
-makelib xcelium_lib/blk_mem_gen_v8_4_4 \
  "../../../ipstatic/simulation/blk_mem_gen_v8_4.v" \
-endlib
-makelib xcelium_lib/xil_defaultlib \
  "../../../../final_project_tetris0.gen/sources_1/ip/blk_mem_gen_0/sim/blk_mem_gen_0.v" \
-endlib
-makelib xcelium_lib/xil_defaultlib \
  glbl.v
-endlib


module ArrayHandlersModule

  use KindModule, only: DP, I4B
  use ConstantsModule, only: MAXCHARLEN
  use SimVariablesModule, only: iout
  private
  public :: ExpandArray, ExtendPtrArray
  public :: ifind
  public :: remove_character

  interface ExpandArray
    ! This interface is for use with ALLOCATABLE arrays.
    ! IMPORTANT: Do not use pointers to elements of arrays when using
    ! ExpandArray to increase the array size!  The locations of array
    ! elements in memory are changed when ExpandArray is invoked.
    module procedure expand_integer, expand_double, &
                     expand_character  !, expand_real
  end interface ExpandArray

  interface ExtendPtrArray
    ! This interface is for use with POINTERS to arrays.
    module procedure extend_double, extend_integer
  end interface

  interface ifind
    module procedure ifind_character, ifind_integer
  end interface ifind

contains

  ! -- Specific procedures that implement ExpandArray for allocatable arrays

  subroutine expand_integer(array, increment)
    implicit none
    ! -- dummy
    integer(I4B), allocatable, intent(inout) :: array(:)
    integer(I4B), optional,    intent(in)    :: increment
    ! -- local
    integer(I4B) :: inclocal, isize, newsize
    integer(I4B), allocatable, dimension(:) :: array_temp
    !
    ! -- initialize
    if (present(increment)) then
      inclocal = increment
    else
      inclocal = 1
    endif
    !
    ! -- increase size of array by inclocal, retaining
    !    contained data
    if (allocated(array)) then
      isize = size(array)
      newsize = isize + inclocal
      allocate(array_temp(newsize))
      array_temp(1:isize) = array
      deallocate(array)
      call move_alloc(array_temp, array)
    else
      allocate(array(inclocal))
    endif
    !
    return
  end subroutine expand_integer

  subroutine expand_double(array, increment)
    implicit none
    ! -- dummy
    real(DP), allocatable, intent(inout) :: array(:)
    integer(I4B), optional,             intent(in)    :: increment
    ! -- local
    integer(I4B) :: inclocal, isize, newsize
    real(DP), allocatable, dimension(:) :: array_temp
    !
    ! -- initialize
    if (present(increment)) then
      inclocal = increment
    else
      inclocal = 1
    endif
    !
    ! -- increase size of array by inclocal, retaining
    !    contained data
    if (allocated(array)) then
      isize = size(array)
      newsize = isize + inclocal
      allocate(array_temp(newsize))
      array_temp(1:isize) = array
      deallocate(array)
      call move_alloc(array_temp, array)
    else
      allocate(array(inclocal))
    endif
    !
    return
  end subroutine expand_double

  subroutine expand_real(array, increment)
    implicit none
    ! -- dummy
    real, allocatable, intent(inout) :: array(:)
    integer(I4B), optional,             intent(in)    :: increment
    ! -- local
    integer(I4B) :: inclocal, isize, newsize
    real, allocatable, dimension(:) :: array_temp
    !
    ! -- initialize
    if (present(increment)) then
      inclocal = increment
    else
      inclocal = 1
    endif
    !
    ! -- increase size of array by inclocal, retaining
    !    contained data
    if (allocated(array)) then
      isize = size(array)
      newsize = isize + inclocal
      allocate(array_temp(newsize))
      array_temp(1:isize) = array
      deallocate(array)
      call move_alloc(array_temp, array)
    else
      allocate(array(inclocal))
    endif
    !
    return
  end subroutine expand_real

  subroutine expand_character(array, increment)
    implicit none
    ! -- dummy
    character(len=*), allocatable, intent(inout) :: array(:)
    integer(I4B), optional,             intent(in)    :: increment
    ! -- local
    integer(I4B) :: i, inclocal, isize, lenc, newsize
    character(len=MAXCHARLEN), allocatable, dimension(:) :: array_temp
    !
    ! -- check character length
    lenc = len(array)
    if (lenc>MAXCHARLEN) then
      ! Can't use store_error or ustop here because SimModule
      ! is dependent on ArrayHandlersModule.
      write(iout,*)'Error in ArrayHandlersModule: Need to increase MAXCHARLEN'
      write(*,*)'Error in ArrayHandlersModule: Need to increase MAXCHARLEN'
      write(iout,*)'Stopping...'
      write(*,*)'Stopping...'
      stop
    endif
    !
    ! -- initialize
    if (present(increment)) then
      inclocal = increment
    else
      inclocal = 1
    endif
    !
    ! -- increase size of array by inclocal, retaining
    !    contained data
    ! [Ned TODO: may be able to use mold here, e.g.:
    !       allocate(values(num), mold=proto)]
    if (allocated(array)) then
      isize = size(array)
      newsize = isize + inclocal
      allocate(array_temp(isize))
      do i=1,isize
        array_temp(i) = array(i)
      enddo
      deallocate(array)
      allocate(array(newsize))
      do i=1,isize
        array(i) = array_temp(i)
      enddo
      do i=isize+1,newsize
        array(i) = ''
      enddo
      deallocate(array_temp)
    else
      allocate(array(inclocal))
    endif
    !
    return
  end subroutine expand_character

  ! -- Specific procedures that implement ExtendPtrArray for pointer arrays

  subroutine extend_double(array, increment)
    implicit none
    ! -- dummy
    real(DP), dimension(:), pointer, contiguous, intent(inout) :: array
    integer(I4B), optional, intent(in) :: increment
    ! -- local
    integer(I4B) :: i, inclocal, isize, istat, newsize
    real(DP), dimension(:), pointer, contiguous :: array_temp => null()
    character(len=100) :: ermsg
    !
    ! -- initialize
    if (present(increment)) then
      inclocal = increment
    else
      inclocal = 1
    endif
    !
    ! -- increase size of array by inclocal, retaining
    !    contained data
    if (associated(array)) then
      isize = size(array)
      newsize = isize + inclocal
      allocate(array_temp(newsize), stat=istat, errmsg=ermsg)
      if (istat /= 0) goto 99
      do i=1,isize
        array_temp(i) = array(i)
      enddo
      deallocate(array)
      array => array_temp
    else
      allocate(array(inclocal))
    endif
    !
    return  ! normal return
    !
    ! -- Error reporting
    99 continue
      ! Can't use store_error or ustop here because SimModule
      ! is dependent on ArrayHandlersModule.
      write(iout,*)'Error encountered while trying to increase array size:'
      write(iout,'(a)')trim(ermsg)
      write(iout,*)'Stopping...'
      write(*,*)'Error encountered while trying to increase array size:'
      write(iout,'(a)')trim(ermsg)
      write(*,*)'Stopping...'
      stop
  end subroutine extend_double

  subroutine extend_integer(array, increment)
    implicit none
    ! -- dummy
    integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: array
    integer(I4B), optional, intent(in) :: increment
    ! -- local
    integer(I4B) :: i, inclocal, isize, istat, newsize
    integer(I4B), dimension(:), pointer, contiguous :: array_temp => null()
    character(len=100) :: ermsg
    !
    ! -- initialize
    if (present(increment)) then
      inclocal = increment
    else
      inclocal = 1
    endif
    !
    ! -- increase size of array by inclocal, retaining
    !    contained data
    if (associated(array)) then
      isize = size(array)
      newsize = isize + inclocal
      allocate(array_temp(newsize), stat=istat, errmsg=ermsg)
      if (istat /= 0) goto 99
      do i=1,isize
        array_temp(i) = array(i)
      enddo
      deallocate(array)
      array => array_temp
    else
      allocate(array(inclocal))
    endif
    !
    return
    !
    ! -- Error reporting
    99 continue
      ! Can't use store_error or ustop here because SimModule
      ! is dependent on ArrayHandlersModule.
      write(iout,*)'Error encountered while trying to increase array size:'
      write(iout,'(a)')trim(ermsg)
      write(iout,*)'Stopping...'
      write(*,*)'Error encountered while trying to increase array size:'
      write(iout,'(a)')trim(ermsg)
      write(*,*)'Stopping...'
      stop
  end subroutine extend_integer

  function ifind_character(array, str)
    ! -- Find the first array element containing str
    ! -- Return -1 if not found.
    implicit none
    ! -- return
    integer(I4B) :: ifind_character
    ! -- dummy
    character(len=*), dimension(:) :: array
    character(len=*) :: str
    ! -- local
    integer(I4B) :: i
    ifind_character = -1
    findloop: do i=1,size(array)
      if(array(i) == str) then
        ifind_character = i
        exit findloop
      endif
    enddo findloop
    return
  end function ifind_character

  function ifind_integer(iarray, ival)
    ! -- Find the first array element containing str
    ! -- Return -1 if not found.
    implicit none
    ! -- return
    integer(I4B) :: ifind_integer
    ! -- dummy
    integer(I4B), dimension(:) :: iarray
    integer(I4B) :: ival
    ! -- local
    integer(I4B) :: i
    ifind_integer = -1
    findloop: do i = 1, size(iarray)
      if(iarray(i) == ival) then
        ifind_integer = i
        exit findloop
      endif
    enddo findloop
    return
  end function ifind_integer

  subroutine remove_character(array, ipos)
    !remove the ipos position from array
    implicit none
    ! -- dummy
    character(len=*), allocatable, intent(inout) :: array(:)
    integer(I4B),                       intent(in)    :: ipos
    ! -- local
    integer(I4B) :: i, isize, lenc, newsize, inew
    character(len=MAXCHARLEN), allocatable, dimension(:) :: array_temp
    !
    ! -- check character length
    lenc = len(array)
    if (lenc>MAXCHARLEN) then
      ! Can't use store_error or ustop here because SimModule
      ! is dependent on ArrayHandlersModule.
      write(iout,*)'Error in ArrayHandlersModule: Need to increase MAXCHARLEN'
      write(*,*)'Error in ArrayHandlersModule: Need to increase MAXCHARLEN'
      write(iout,*)'Stopping...'
      write(*,*)'Stopping...'
      stop
    endif
    !
    ! -- calculate sizes
    isize = size(array)
    newsize = isize - 1
    !
    ! -- copy array to array_temp
    allocate(array_temp(isize))
    do i = 1, isize
      array_temp(i) = array(i)
    enddo
    !
    deallocate(array)
    allocate(array(newsize))
    inew = 1
    do i = 1, isize
      if(i /= ipos) then
        array(inew) = array_temp(i)
        inew = inew + 1
      endif
    enddo
    deallocate(array_temp)
    !
    return
  end subroutine remove_character

end module ArrayHandlersModule


text:
      SUBROUTINE DLBLKS( NAME, NBC)
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C        ENLEVER LES BLANCS EN DEBUT D'UNE CHAINE DE CARACTERES
C
C
C ENTREE : NAME  LA CHAINE DE CARACTERES
C
C SORTIE : NAME  LA CHAINE SANS LES BLANCS
C          NBC   NOMBRE DE CARACTERES DE LA CHAINE
C
C FORTRAN  INDEX, LEN
C ....................................................................
c     Copyright INRIA
      CHARACTER*(*) NAME
      INTEGER       NBC
      INTEGER       I,K,J,LL
C
      LL = LEN ( NAME )
      I  =  0
    1 I  =  I + 1
         K  = INDEX ( NAME(I:LL) , ' ' )
         IF ( K .EQ. 0 ) K = LL - I + 2
         IF ( K .EQ. 1  .AND.  I .LT. LL ) GO TO 1
C
      NBC = K - 1
      I   = I - 1
      DO 3 J = 1,NBC
         NAME(J:J) = NAME(J+I:J+I)
    3 CONTINUE
      DO 5 J = NBC+1,LL
         NAME(J:J) = ' '
    5 CONTINUE
C
C
      END

max_stars_repo_name: alpgodev/numx

max_issues_repo_name: alpgodev/numx

max_forks_repo_name: alpgodev/numx


text:
SUBROUTINE CALDISP3

  ! CHANGE RECORD

  USE GLOBAL

  IMPLICIT NONE
  INTEGER :: K,KK,L,LS,KT,LN
  REAL :: CLTMP,DDD,CMTMP,DXXTMP,WTX,DXXWEST,DXXEAST
  REAL :: DXXSOUT,DXXNORT,WTY,DYXWEST,DYXEAST,DYXSOUT,DYXNORT
  REAL :: DYYTMP,DYYWEST,DYYSOUT,DYYNORT,DYYEAST,AMCPT,AMSPT
  REAL :: DXYWEST,DXYEAST,DXYSOUT,DXYNORT,DYXTMP,DMAX,DXYTMP
  REAL :: CCUU,CCVV,CCUV,CCVU,TPNN,UAVG,VAVG,CUTMP,CTMP

  ! *** DS-INTL BEGIN BLOCK
  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: INDX
  REAL,SAVE,ALLOCATABLE,DIMENSION(:) :: CCUTMP
  REAL,SAVE,ALLOCATABLE,DIMENSION(:) :: CCVTMP
  REAL,SAVE,ALLOCATABLE,DIMENSION(:) :: CSOL
  REAL,SAVE,ALLOCATABLE,DIMENSION(:) :: UP
  REAL,SAVE,ALLOCATABLE,DIMENSION(:) :: VP
  REAL,SAVE,ALLOCATABLE,DIMENSION(:,:) :: CCTMP
  REAL,SAVE,ALLOCATABLE,DIMENSION(:,:) :: CDISP
  REAL,SAVE,ALLOCATABLE,DIMENSION(:,:) :: CDISPI

  IF(  .NOT. ALLOCATED(INDX) )THEN
    ALLOCATE(INDX(KC))
    ALLOCATE(CCUTMP(KCM))
    ALLOCATE(CCVTMP(KCM))
    ALLOCATE(CSOL(MGM))
    ALLOCATE(UP(KCM))
    ALLOCATE(VP(KCM))
    ALLOCATE(CCTMP(KCM,KCM))
    ALLOCATE(CDISP(MGM,MGM))
    ALLOCATE(CDISPI(KCM,KCM))

    ! *** ZERO LOCAL ARRAYS
    INDX=0
    CCUTMP=0.0
    CCVTMP=0.0
    CSOL=0.0
    UP=0.0
    VP=0.0
    CCTMP=0.0
    CDISP=0.0
    CDISPI=0.0
  ENDIF
  ! *** DS-INTL END BLOCK

  ! **  INITIALIZE ON FIRST CALL
  IF( N == NDISP )THEN
    DO L=1,LC
      DO KK=1,KC
        DO K=1,KC
          BDISP(K,KK,L)=0.
        ENDDO
      ENDDO
    ENDDO
    DO L=1,LC
      DO K=1,KC
        BDISP(K,K,L)=1.
        FUDISP(K,L)=0.
        FVDISP(K,L)=0.
      ENDDO
    ENDDO
    DO L=1,LC
      DXXTCA(L)=0.
      DXYTCA(L)=0.
      DYXTCA(L)=0.
      DYYTCA(L)=0.
    ENDDO
  ENDIF

  ! **  CALCULATE VERTICAL DIFFUSION MATRIX AND INVERSE AND ACCUMULATE
  ! **  DATA FOR DISPERSION CALCULATION
  DELT=FLOAT(NTSTBC)*DT
  DO L=2,LA
    IF( LCT(L) == 5 .AND. SPB(L) /= 0. )THEN
      LN=LNC(L)
      DO K=1,KC
        UP(K)=0.5*(U(L,K)+U(LEC(L),K))
        VP(K)=0.5*(V(L,K)+V(LN,K))
      ENDDO
      UAVG=0.
      VAVG=0.
      DO K=1,KC
        UAVG=UAVG+DZC(L,K)*UP(K)
        VAVG=VAVG+DZC(L,K)*VP(K)
      ENDDO
      DO K=1,KC
        UP(K)=UP(K)-UAVG
        VP(K)=VP(K)-VAVG
      ENDDO
      DO KK=1,KC
        DO K=1,KC
          CDISP(K,KK)=0.
        ENDDO
      ENDDO
      CUTMP=-DELT*CDZKK(L,1)*AB(L,1)*HPI(L)
      CMTMP=1.-CUTMP
      CDISP(1,1)=CMTMP*DZC(L,KSZ(L))
      CDISP(1,2)=CUTMP*DZC(L,KSZ(L))
      DO K=2,KS
        CLTMP=-DELT*CDZKMK(L,K)*AB(L,K-1)*HPI(L)
        CUTMP=-DELT*CDZKK(L,K)*AB(L,K)*HPI(L)
        CMTMP=1.-CLTMP-CUTMP
        CDISP(K,K-1)=CLTMP*DZC(L,K)
        CDISP(K,K)=CMTMP*DZC(L,K)
        CDISP(K,K+1)=CUTMP*DZC(L,K)
      ENDDO
      CLTMP=-DELT*CDZKMK(L,KC)*AB(L,KS)*HPI(L)
      CMTMP=1.-CLTMP
      CDISP(KC,KS)=CLTMP*DZC(L,KC)
      CDISP(KC,KC)=CMTMP*DZC(L,KC)
      CALL LUDCMP(CDISP,KC,MGM,INDX,DDD)
      DO KK=1,KC
        DO K=1,KC
          CDISPI(K,KK)=0.
        ENDDO
      ENDDO
      DO K=1,KC
        CDISPI(K,K)=1.
      ENDDO
      DO K=1,KC
        CALL LUBKSB(CDISP,KC,MGM,INDX,CDISPI(1,K))
      ENDDO
      DO KK=1,KC
        DO K=1,KC
          CDISPI(K,KK)=CDISPI(K,KK)*DZC(L,K)
        ENDDO
      ENDDO
      DO KK=1,KC
        DO K=1,KC
          CTMP=0.
          DO KT=1,KC
            CTMP=CTMP+CDISPI(K,KT)*BDISP(KT,KK,L)
          ENDDO
          CCTMP(K,KK)=CTMP
        ENDDO
      ENDDO
      DO KK=1,KC
        DO K=1,KC
          BDISP(K,KK,L)=CCTMP(K,KK)
        ENDDO
      ENDDO
      DO K=1,KC
        CCUTMP(K)=FUDISP(K,L)-DT*UP(K)/HMIN
        CCVTMP(K)=FVDISP(K,L)-DT*VP(K)/HMIN
      ENDDO
      DO K=1,KC
        CCUU=0.
        CCVV=0.
        DO KK=1,KC
          CCUU=CCUU+CDISPI(K,KK)*CCUTMP(KK)
          CCVV=CCVV+CDISPI(K,KK)*CCVTMP(KK)
        ENDDO
        FUDISP(K,L)=CCUU
        FVDISP(K,L)=CCVV
      ENDDO
      CCUU=0.
      CCVV=0.
      CCUV=0.
      CCVU=0.
      DO K=1,KC
        CCUU=CCUU+DZC(L,K)*UP(K)*FUDISP(K,L)
        CCUV=CCUV+DZC(L,K)*UP(K)*FVDISP(K,L)
        CCVU=CCVU+DZC(L,K)*VP(K)*FUDISP(K,L)
        CCVV=CCVV+DZC(L,K)*VP(K)*FVDISP(K,L)
      ENDDO
      DXXTCA(L)=DXXTCA(L)+CCUU*HP(L)
      DXYTCA(L)=DXYTCA(L)+CCUV*HP(L)
      DYXTCA(L)=DYXTCA(L)+CCVU*HP(L)
      DYYTCA(L)=DYYTCA(L)+CCVV*HP(L)
      DO K=1,KC
        CCUU=0.
        CCVV=0.
        DO KK=1,KC
          CCUU=CCUU+DZC(L,KK)*UP(KK)*BDISP(KK,K,L)
          CCVV=CCVV+DZC(L,KK)*VP(KK)*BDISP(KK,K,L)
        ENDDO
        CUDISPT(K,L)=CCUU*HP(L)
        CVDISPT(K,L)=CCVV*HP(L)
      ENDDO
    ENDIF
  ENDDO
  IF( N < NTS) RETURN

  ! **  COMPLETE CALCULATION OF DISPERSION COEFFICIENTS
  TPNN=TPN/FLOAT(NTSTBC)
  DO L=2,LA
    IF( LCT(L) == 5 .AND. SPB(L) /= 0. )THEN
      DO KK=1,KC
        DO K=1,KC
          CDISP(K,KK)=-BDISP(K,KK,L)
        ENDDO
      ENDDO
      DO K=1,KC
        CDISP(K,K)=1.+CDISP(K,K)
      ENDDO
      CALL LUDCMP(CDISP,KC,MGM,INDX,DDD)
      DO K=1,KC
        CSOL(K)=FUDISP(K,L)
      ENDDO
      CALL LUBKSB(CDISP,KC,MGM,INDX,CSOL)
      CCUU=0.
      CCVU=0.
      DO K=1,KC
        CCUU=CCUU+CUDISPT(K,L)*CSOL(K)
        CCVU=CCVU+CVDISPT(K,L)*CSOL(K)
      ENDDO
      DXXTCA(L)=-(DXXTCA(L)+CCUU)*HMIN/TPNN
      DYXTCA(L)=-(DYXTCA(L)+CCVU)*HMIN/TPNN
      DO K=1,KC
        CSOL(K)=FVDISP(K,L)
      ENDDO
      CALL LUBKSB(CDISP,KC,MGM,INDX,CSOL)
      CCVV=0.
      CCUV=0.
      DO K=1,KC
        CCVV=CCVV+CVDISPT(K,L)*CSOL(K)
        CCUV=CCUV+CUDISPT(K,L)*CSOL(K)
      ENDDO
      DYYTCA(L)=-(DYYTCA(L)+CCVV)*HMIN/TPNN
      DXYTCA(L)=-(DXYTCA(L)+CCUV)*HMIN/TPNN
    ENDIF
  ENDDO
  DO L=2,LA
    DXXTCA(L)=DXXTCA(L)/HLPF(L)
    DXYTCA(L)=DXYTCA(L)/HLPF(L)
    DYXTCA(L)=DYXTCA(L)/HLPF(L)
    DYYTCA(L)=DYYTCA(L)/HLPF(L)
  ENDDO

  ! **  ADJUST DISPERSON TENSOR COMPONENTS
  OPEN(88,FILE=OUTDIR//'DISDIA.OUT',STATUS='UNKNOWN')
  CLOSE(88,STATUS='DELETE')
  OPEN(88,FILE=OUTDIR//'DISDIA.OUT',STATUS='UNKNOWN')
  DMAX=10000.
  DO L=2,LA
    DXXTMP=DXXTCA(L)
    IF( DXXTMP < 0 .OR. DXXTMP > DMAX )THEN
      WRITE(88,8881)IL(L),JL(L),DXXTMP
      DXXTCA(L)=0.
      LN=LNC(L)
      LS=LSC(L)
      WTX=0.
      DXXWEST=0.
      DXXEAST=0.
      DXXSOUT=0.
      DXXNORT=0.
      IF( SUB(L) /= 0 )THEN
        DXXWEST=DXXTCA(LWC(L))
        IF( DXXWEST < 0 .OR. DXXWEST > DMAX )THEN
          DXXWEST=0.
        ELSE
          WTX=WTX+1
        ENDIF
      ENDIF
      IF( SUB(LEC(L)) /= 0 )THEN
        DXXEAST=DXXTCA(LEC(L))
        IF( DXXEAST < 0 .OR. DXXEAST > DMAX )THEN
          DXXEAST=0.
        ELSE
          WTX=WTX+1
        ENDIF
      ENDIF
      IF( SVB(L) /= 0 )THEN
        DXXSOUT=DXXTCA(LS)
        IF( DXXSOUT < 0 .OR. DXXSOUT > DMAX )THEN
          DXXSOUT=0.
        ELSE
          WTX=WTX+1
        ENDIF
      ENDIF
      IF( SVB(LN) /= 0 )THEN
        DXXNORT=DXXTCA(LN)
        IF( DXXNORT < 0 .OR. DXXNORT > DMAX )THEN
          DXXNORT=0.
        ELSE
          WTX=WTX+1
        ENDIF
      ENDIF
      IF( WTX /= 0) DXXTCA(L)=(DXXWEST+DXXEAST+DXXSOUT+DXXNORT)/WTX
    ENDIF
  ENDDO
  DO L=2,LA
    DXYTMP=DXYTCA(L)
    IF( ABS(DXYTMP) > DMAX )THEN
      WRITE(88,8882)IL(L),JL(L),DXYTMP
      DXYTCA(L)=0.
      LN=LNC(L)
      LS=LSC(L)
      WTX=0.
      DXYWEST=0.
      DXYEAST=0.
      DXYSOUT=0.
      DXYNORT=0.
      IF( SUB(L) /= 0 )THEN
        DXYWEST=DXYTCA(LWC(L))
        IF( ABS(DXYWEST) > DMAX )THEN
          DXYWEST=0.
        ELSE
          WTX=WTX+1
        ENDIF
      ENDIF
      IF( SUB(LEC(L)) /= 0 )THEN
        DXYEAST=DXYTCA(LEC(L))
        IF( ABS(DXYEAST) > DMAX )THEN
          DXYEAST=0.
        ELSE
          WTX=WTX+1
        ENDIF
      ENDIF
      IF( SVB(L) /= 0 )THEN
        DXYSOUT=DXYTCA(LS)
        IF( ABS(DXYSOUT) > DMAX )THEN
          DXYSOUT=0.
        ELSE
          WTX=WTX+1
        ENDIF
      ENDIF
      IF( SVB(LN) /= 0 )THEN
        DXYNORT=DXYTCA(LN)
        IF( ABS(DXYNORT) > DMAX )THEN
          DXYNORT=0.
        ELSE
          WTX=WTX+1
        ENDIF
      ENDIF
      DXYTCA(L)=(DXYWEST+DXYEAST+DXYSOUT+DXYNORT)/WTX
    ENDIF
  ENDDO
  DO L=2,LA
    DYXTMP=DYXTCA(L)
    IF( DYXTMP > DMAX )THEN
      WRITE(88,8883)IL(L),JL(L),DYXTMP
      DYXTCA(L)=0.
      LN=LNC(L)
      LS=LSC(L)
      WTY=0.
      DYXWEST=0.
      DYXEAST=0.
      DYXSOUT=0.
      DYXNORT=0.
      IF( SUB(L) /= 0 )THEN
        DYXWEST=DYXTCA(LWC(L))
        IF( ABS(DYXWEST) > DMAX )THEN
          DYXWEST=0.
        ELSE
          WTY=WTY+1
        ENDIF
      ENDIF
      IF( SUB(LEC(L)) /= 0 )THEN
        DYXEAST=DYXTCA(LEC(L))
        IF( ABS(DYXEAST) > DMAX )THEN
          DYXEAST=0.
        ELSE
          WTY=WTY+1
        ENDIF
      ENDIF
      IF( SVB(L) /= 0 )THEN
        DYYSOUT=DYYTCA(LS)
        IF( ABS(DYXSOUT) > DMAX )THEN
          DYXSOUT=0.
        ELSE
          WTY=WTY+1
        ENDIF
      ENDIF
      IF( SVB(LN) /= 0 )THEN
        DYYNORT=DYYTCA(LN)
        IF( ABS(DYXNORT) > DMAX )THEN
          DYXNORT=0.
        ELSE
          WTY=WTY+1
        ENDIF
      ENDIF
      DYXTCA(L)=(DYXWEST+DYXEAST+DYXSOUT+DYXNORT)/WTY
    ENDIF
  ENDDO
  DO L=2,LA
    DYYTMP=DYYTCA(L)
    IF( DYYTMP < 0 .OR. DYYTMP > DMAX )THEN
      WRITE(88,8884)IL(L),JL(L),DYYTMP
      DYYTCA(L)=0.
      LN=LNC(L)
      LS=LSC(L)
      WTY=0.
      DYYWEST=0.
      DYYEAST=0.
      DYYSOUT=0.
      DYYNORT=0.
      IF( SUB(L) /= 0 )THEN
        DYYWEST=DYYTCA(LWC(L))
        IF( DYYWEST < 0 .OR. DYYWEST > DMAX )THEN
          DYYWEST=0.
        ELSE
          WTY=WTY+1
        ENDIF
      ENDIF
      IF( SUB(LEC(L)) /= 0 )THEN
        DYYEAST=DYYTCA(LEC(L))
        IF( DYYEAST < 0 .OR. DYYEAST > DMAX )THEN
          DYYEAST=0.
        ELSE
          WTY=WTY+1
        ENDIF
      ENDIF
      IF( SVB(L) /= 0 )THEN
        DYYSOUT=DYYTCA(LS)
        IF( DYYSOUT < 0 .OR. DYYSOUT > DMAX )THEN
          DYYSOUT=0.
        ELSE
          WTY=WTY+1
        ENDIF
      ENDIF
      IF( SVB(LN) /= 0 )THEN
        DYYNORT=DYYTCA(LN)
        IF( DYYNORT < 0 .OR. DYYNORT > DMAX )THEN
          DYYNORT=0.
        ELSE
          WTY=WTY+1
        ENDIF
      ENDIF
      DYYTCA(L)=(DYYWEST+DYYEAST+DYYSOUT+DYYNORT)/WTY
    ENDIF
  ENDDO
  CLOSE(88)
   8881 FORMAT('  I=',I5,2X,'J=',I5,2X,'DXX= ',E12.4)
   8882 FORMAT('  I=',I5,2X,'J=',I5,2X,'DXY= ',E12.4)
   8883 FORMAT('  I=',I5,2X,'J=',I5,2X,'DYX= ',E12.4)
   8884 FORMAT('  I=',I5,2X,'J=',I5,2X,'DYY= ',E12.4)

  ! **  WRITE OUTPUT FILES
  OPEN(88,FILE=OUTDIR//'DISTEN.OUT',STATUS='UNKNOWN')
  CLOSE(88,STATUS='DELETE')
  OPEN(88,FILE=OUTDIR//'DISTEN.OUT',STATUS='UNKNOWN')
  WRITE(88,881)
  DO L=2,LA
    WRITE(88,2011)IL(L),JL(L),DLON(L),DLAT(L),DXXTCA(L),DXYTCA(L),DYXTCA(L),DYYTCA(L)
  ENDDO
  CLOSE(88)
  OPEN(88,FILE=OUTDIR//'UVTSC.OUT',STATUS='UNKNOWN')
  CLOSE(88,STATUS='DELETE')
  OPEN(88,FILE=OUTDIR//'UVTSC.OUT',STATUS='UNKNOWN')
  WRITE(88,882)
  DO L=2,LA
    AMCPT=AMCP(L)*GI
    AMSPT=AMSP(L)*GI
    WRITE(88,2012)IL(L),JL(L),DLON(L),DLAT(L),AMCPT,AMSPT,AMCUE(L),AMSUE(L),AMCVE(L),AMSVE(L)
  ENDDO
  CLOSE(88)
  OPEN(88,FILE=OUTDIR//'UVERV.OUT',STATUS='UNKNOWN')
  CLOSE(88,STATUS='DELETE')
  OPEN(88,FILE=OUTDIR//'UVERV.OUT',STATUS='UNKNOWN')
  WRITE(88,883)
  DO L=2,LA
    WRITE(88,2012)IL(L),JL(L),DLON(L),DLAT(L),HLPF(L),UELPF(L),VELPF(L),SALLPF(L,KSZ(L)),SALLPF(L,KC)
  ENDDO
  CLOSE(88)

  881 FORMAT(3X,'I',3X,'J',3X,'LON',9X,'LAT',9X,'DXX',10X,'DXY',10X,'DYX',10X,'DYY')
  882 FORMAT(3X,'I',3X,'J',3X,'LON',9X,'LAT',9X,'AMCPT',8X,'AMSPT',8X,'AMCUE',8X,'AMSUE',8X,'AMCVE',8X,'AMSVE')
  883 FORMAT(3X,'I',3X,'J',3X,'LON',9X,'LAT',9X,'HLPF',9X,'UELPF',8X,'VELPF',8X,'SALLPFBOT',4X,'SALLPFSURF')
  2011 FORMAT(2I4,2X,F10.6,2X,F10.6,4(2X,E12.4))
  2012 FORMAT(2I4,2X,F10.6,2X,F10.6,6(2X,E12.4))
  RETURN
END

max_stars_repo_name: dsi-llc/EFDCPlus

max_forks_repo_name: dsi-llc/EFDCPlus


text:
      SUBROUTINE RED(IZ1,IZ2,JZ1,JZ2,JM1,JM2,JMF,IC1,JC1,JCF,KC,
     *    C,NCI,NCJ,NCK,S,NSI,NSJ)
      DIMENSION C(NCI,NCJ,NCK),S(NSI,NSJ)
      LOFF=JC1-JM1
      IC=IC1
      DO 14 J=JZ1,JZ2
        DO 12 L=JM1,JM2
          VX=C(IC,L+LOFF,KC)
          DO 11 I=IZ1,IZ2
            S(I,L)=S(I,L)-S(I,J)*VX
11        CONTINUE
12      CONTINUE
        VX=C(IC,JCF,KC)
        DO 13 I=IZ1,IZ2
          S(I,JMF)=S(I,JMF)-S(I,J)*VX
13      CONTINUE
        IC=IC+1
14    CONTINUE
      RETURN
      END

ext: for


text:
!  *********************************************************************
!  *                                                                   *
!  *                           function dcvab1                         *
!  *                                                                   *
!  *********************************************************************
!  Double Precision Version 1.4
!  Written by Gordon A. Fenton, DalTech, Jun 9, 2000
!  Latest Update: Apr 8, 2001
!
!  PURPOSE  returns the covariance between two 1-D local averages, one of
!           twice the length of the other. Used by LAS1G.
!
!  This function evaluates the covariance between two local averages in
!  1-dimensional space. The local averages are assumed to be of size Dx
!  and 2*Dx, and separated in space by the lag Tx=C1*Dx, center-to-center.
!
!  The covariance is obtained by a 5-pt Gaussian quadrature of a
!  1-dimensional integral of the externally provided point covariance
!  function of the process
!
!                   1    (C1-0.5)*Dx
!  Cov[X_a, X_b] = --- [ int  {x - (C1-1.5)Dx}*cov(x) dx
!                 2Dx^2 (C1-1.5)Dx
!
!			(C1+0.5)Dx
!			+ int Dx*cov(x) dx
!			(C1-0.5)*Dx
!
!			(C1+1.5)Dx
!			+ int {(C1+1.5) - Dx}*cov(x) dx ]
!			(C1+0.5)*Dx
!
!
!  Where X_a and X_b are the local averages of the two areas, of size
!  Dx and 2*DX, respectively, and separated center-to-center by lag C1*Dx.
!
!  The covariance function is referenced herein using a call of the form
!
!          V = cov( X )
!
!  where X is the lag distances between the points in the field.
!
!  Arguments to this function are as follows
!
!    cov       external variance/covariance function provided by the user.
!
!    Dx        x-dimension of the smaller local average. (input)
!
!    C1        x-direction distance between local average centers is C1*Dx.
!               (input)
!
!  REVISION HISTORY:
!  1.1	eliminated lvarfn - now choose integration method to minimize
!	errors. (Feb 27/01)
!  1.2	now choose Gauss Quadrature except when intervals overlap. (Apr 5/01)
!  1.3	now use Gauss Quadrature for everything (Apr 16/01)
!  1.4	now use 16-pt Gauss quadrature for increased accuracy (Apr 8/02)
!---------------------------------------------------------------------------
      real*8 function dcvab1( cov, Dx, C1 )
      parameter (NG = 16)
      implicit real*8 (a-h,o-z)
      dimension w(NG), z(NG)

      external cov

      data zero/0.d0/, eighth/0.125d0/, half/0.5d0/
      data one/1.d0/, onept5/1.5d0/, two/2.d0/

!			these are for NG = 3
!     data w/0.555555555555556d0,.888888888888889d0,.555555555555556d0/
!     data z/-.774596669241483d0,.000000000000000d0,.774596669241483d0/
!			and these are for NG = 5
!     data w/ .236926885056189d0,.478628670499366d0,.568888888888889d0,
!    >        .478628670499366d0,.236926885056189d0/
!     data z/-.906179845938664d0,-.538469310105683d0,.000000000000000d0,
!    >        .538469310105683d0, .906179845938664d0/
!			these are for NG = 16
      data w/0.027152459411754094852d0, 0.062253523938647892863d0,  &
            0.095158511682492784810d0, 0.124628971255533872052d0,  &
            0.149595988816576732081d0, 0.169156519395002538189d0,  &
            0.182603415044923588867d0, 0.189450610455068496285d0,  &
            0.189450610455068496285d0, 0.182603415044923588867d0,  &
            0.169156519395002538189d0, 0.149595988816576732081d0,  &
            0.124628971255533872052d0, 0.095158511682492784810d0,  &
            0.062253523938647892863d0, 0.027152459411754094852d0/
      data z/-.989400934991649932596d0, -.944575023073232576078d0,  &
            -.865631202387831743880d0, -.755404408355003033895d0,  &
            -.617876244402643748447d0, -.458016777657227386342d0,  &
            -.281603550779258913230d0, -.095012509837637440185d0,  &
            0.095012509837637440185d0, 0.281603550779258913230d0,  &
            0.458016777657227386342d0, 0.617876244402643748447d0,  &
            0.755404408355003033895d0, 0.865631202387831743880d0,  &
            0.944575023073232576078d0, 0.989400934991649932596d0/

      abs(zz) = dabs(zz)
!					if intervals overlap, use special form
      if( abs(C1) .lt. one ) then	! NOTE: this really just means C1 = 0.5
         d1 = zero
         do 10 i = 1, NG
            xi = Dx*(one + z(i))
            d1 = d1 + w(i)*(one-z(i))*cov(xi)
  10     continue
         dcvab1 = half*d1
         return
      endif
!					otherwise, use GQ for non-overlapping
!					intervals
      r1 = half*Dx
      s2 = two*C1
      s1 = s2 - two
      s3 = s2 + two
      d1 = zero
      do 20 i = 1, NG
         xi1 = r1*(z(i) + s1)
         xi2 = r1*(z(i) + s2)
         xi3 = r1*(z(i) + s3)
         q1  = (one + z(i))*cov(xi1)
         q2  = two*cov(xi2)
         q3  = (one - z(i))*cov(xi3)
         d1  = d1 + w(i)*(q1 + q2 + q3)
  20  continue
      dcvab1 = eighth*d1

      return
      end

max_stars_repo_name: leemargetts/PoreFEM

max_issues_repo_name: leemargetts/PoreFEM

max_forks_repo_name: leemargetts/PoreFEM


text:
Assistant Manager at Adobe at Evergreen Apartments / Tandem Properties
Katie Graduated from UC Davis in 13 with a degree in Communication
Katie had lived in Davis since 10

 Ask me about housing in Davis!! :)

E: kmacfabe@tandemproperties.com

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! ==============================================================================
! hipfort: FORTRAN Interfaces for GPU kernels
! ==============================================================================
! Copyright (c) 2020-2022 Advanced Micro Devices, Inc. All rights reserved.
! [MITx11 License]
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in
! all copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.  IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

module hipfort_rocfft
  use hipfort_rocfft_enums
  implicit none

  !>  @brief Library setup function, called once in program before start of
  !>  library use
  interface rocfft_setup
    function rocfft_setup_() bind(c, name="rocfft_setup")
      use iso_c_binding
      use hipfort_rocfft_enums
      implicit none
      integer(kind(rocfft_status_success)) :: rocfft_setup_
    end function

  end interface
  !>  @brief Library cleanup function, called once in program after end of library
  !>  use
  interface rocfft_cleanup
    function rocfft_cleanup_() bind(c, name="rocfft_cleanup")
      use iso_c_binding
      use hipfort_rocfft_enums
      implicit none
      integer(kind(rocfft_status_success)) :: rocfft_cleanup_
    end function

  end interface
  !>  @brief Create an FFT plan
  !>
  !>   @details This API creates a plan, which the user can execute
  !>   subsequently.  This function takes many of the fundamental
  !>   parameters needed to specify a transform.
  !>
  !>   The dimensions parameter can take a value of 1, 2, or 3. The
  !>   'lengths' array specifies the size of data in each dimension. Note
  !>   that lengths[0] is the size of the innermost dimension, lengths[1]
  !>   is the next higher dimension and so on (column-major ordering).
  !>
  !>   The 'number_of_transforms' parameter specifies how many
  !>   transforms (of the same kind) needs to be computed. By specifying
  !>   a value greater than 1, a batch of transforms can be computed
  !>   with a single API call.
  !>
  !>   Additionally, a handle to a plan description can be passed for
  !>   more detailed transforms. For simple transforms, this parameter
  !>   can be set to NULL.
  !>
  !>   The plan must be destroyed with a call to ::rocfft_plan_destroy.
  !>
  !>   @param[out] plan plan handle
  !>   @param[in] placement placement of result
  !>   @param[in] transform_type type of transform
  !>   @param[in] precision precision
  !>   @param[in] dimensions dimensions
  !>   @param[in] lengths dimensions-sized array of transform lengths
  !>   @param[in] number_of_transforms number of transforms
  !>   @param[in] description description handle created by
  !>  rocfft_plan_description_create; can be
  !>   NULL for simple transforms
  interface rocfft_plan_create
    function rocfft_plan_create_(plan,placement,transform_type,myPrecision,dimensions,lengths,number_of_transforms,description) bind(c, name="rocfft_plan_create")
      use iso_c_binding
      use hipfort_rocfft_enums
      implicit none
      integer(kind(rocfft_status_success)) :: rocfft_plan_create_
      type(c_ptr) :: plan
      integer(kind(rocfft_placement_inplace)),value :: placement
      integer(kind(rocfft_transform_type_complex_forward)),value :: transform_type
      integer(kind(rocfft_precision_single)),value :: myPrecision
      integer(c_size_t),value :: dimensions
      type(c_ptr),value :: lengths
      integer(c_size_t),value :: number_of_transforms
      type(c_ptr),value :: description
    end function

#ifdef USE_FPOINTER_INTERFACES
    module procedure &
      rocfft_plan_create_rank_0,&
      rocfft_plan_create_rank_1
#endif
  end interface
  !>  @brief Execute an FFT plan
  !>
  !>   @details This API executes an FFT plan on buffers given by the user.
  !>
  !>   If the transform is in-place, only the input buffer is needed and
  !>   the output buffer parameter can be set to NULL. For not in-place
  !>   transforms, output buffers have to be specified.
  !>
  !>   Input and output buffer are arrays of pointers.  Interleaved
  !>   array formats are the default, and require just one pointer per
  !>   input or output buffer.  Planar array formats require two
  !>   pointers per input or output buffer - real and imaginary
  !>   pointers, in that order.
  !>
  !>   Note that input buffers may still be overwritten during execution
  !>   of a transform, even if the transform is not in-place.
  !>
  !>   The final parameter in this function is a rocfft_execution_info
  !>   handle. This optional parameter serves as a way for the user to control
  !>   execution streams and work buffers.
  !>
  !>   @param[in] plan plan handle
  !>   @param[in,out] in_buffer array (of size 1 for interleaved data, of size 2
  !>  for planar data) of input buffers
  !>   @param[in,out] out_buffer array (of size 1 for interleaved data, of size 2
  !>  for planar data) of output buffers, ignored for in-place transforms
  !>   @param[in] info execution info handle created by
  !>  rocfft_execution_info_create
  interface rocfft_execute
    function rocfft_execute_(plan,in_buffer,out_buffer,myInfo) bind(c, name="rocfft_execute")
      use iso_c_binding
      use hipfort_rocfft_enums
      implicit none
      integer(kind(rocfft_status_success)) :: rocfft_execute_
      type(c_ptr),value :: plan
      type(c_ptr) :: in_buffer
      type(c_ptr) :: out_buffer
      type(c_ptr),value :: myInfo
    end function

  end interface
  !>  @brief Destroy an FFT plan
  !>   @details This API frees the plan after it is no longer needed.
  !>   @param[in] plan plan handle
  interface rocfft_plan_destroy
    function rocfft_plan_destroy_(plan) bind(c, name="rocfft_plan_destroy")
      use iso_c_binding
      use hipfort_rocfft_enums
      implicit none
      integer(kind(rocfft_status_success)) :: rocfft_plan_destroy_
      type(c_ptr),value :: plan
    end function

  end interface
  !>  @brief Set scaling factor in single precision
  !>   @details This is one of plan description functions to specify optional additional plan properties using the description handle. This API specifies scaling factor.
  !>   @param[in] description description handle
  !>   @param[in] scale scaling factor
  interface rocfft_plan_description_set_scale_float
    function rocfft_plan_description_set_scale_float_(description,scale) bind(c, name="rocfft_plan_description_set_scale_float")
      use iso_c_binding
      use hipfort_rocfft_enums
      implicit none
      integer(kind(rocfft_status_success)) :: rocfft_plan_description_set_scale_float_
      type(c_ptr),value :: description
      real(c_float),value :: scale
    end function

  end interface
  !>  @brief Set scaling factor in double precision
  !>   @details This is one of plan description functions to specify optional additional plan properties using the description handle. This API specifies scaling factor.
  !>   @param[in] description description handle
  !>   @param[in] scale scaling factor
  interface rocfft_plan_description_set_scale_double
    function rocfft_plan_description_set_scale_double_(description,scale) bind(c, name="rocfft_plan_description_set_scale_double")
      use iso_c_binding
      use hipfort_rocfft_enums
      implicit none
      integer(kind(rocfft_status_success)) :: rocfft_plan_description_set_scale_double_
      type(c_ptr),value :: description
      real(c_double),value :: scale
    end function

  end interface
  !>   @brief Set advanced data layout parameters on a plan description
  !>
  !>   @details This API specifies advanced layout of input/output
  !>   buffers for a plan description.
  !>
  !>   The following parameters are supported for inputs and outputs:
  !>
  !>   * Array type (real, hermitian, or complex data, in either
  !>     interleaved or planar format).
  !>       * Real forward transforms require real input and hermitian output.
  !>       * Real inverse transforms require hermitian input and real output.
  !>       * Complex transforms require complex input and output.
  !>       * Hermitian and complex data defaults to interleaved if a specific
  !>           format is not specified.
  !>   * Offset of first data element in the data buffer.  Defaults to 0 if unspecified.
  !>   * Stride between consecutive elements in each dimension.  Defaults
  !>       to contiguous data in all dimensions if unspecified.
  !>   * Distance between consecutive batches.  Defaults to contiguous
  !>       batches if unspecified.
  !>
  !>   Not all combinations of array types are supported and error codes
  !>   will be returned for unsupported cases.
  !>
  !>   @param[in, out] description description handle
  !>   @param[in] in_array_type array type of input buffer
  !>   @param[in] out_array_type array type of output buffer
  !>   @param[in] in_offsets offsets, in element units, to start of data in input buffer
  !>   @param[in] out_offsets offsets, in element units, to start of data in output buffer
  !>   @param[in] in_strides_size size of in_strides array (must be equal to transform dimensions)
  !>   @param[in] in_strides array of strides, in each dimension, of
  !>    input buffer; if set to null ptr library chooses defaults
  !>   @param[in] in_distance distance between start of each data instance in input buffer
  !>   @param[in] out_strides_size size of out_strides array (must be
  !>   equal to transform dimensions)
  !>   @param[in] out_strides array of strides, in each dimension, of
  !>    output buffer; if set to null ptr library chooses defaults
  !>   @param[in] out_distance distance between start of each data instance in output buffer
  interface rocfft_plan_description_set_data_layout
    function rocfft_plan_description_set_data_layout_(description,in_array_type,out_array_type,in_offsets,out_offsets,in_strides_size,in_strides,in_distance,out_strides_size,out_strides,out_distance) bind(c, name="rocfft_plan_description_set_data_layout")
      use iso_c_binding
      use hipfort_rocfft_enums
      implicit none
      integer(kind(rocfft_status_success)) :: rocfft_plan_description_set_data_layout_
      type(c_ptr),value :: description
      integer(kind(rocfft_array_type_complex_interleaved)),value :: in_array_type
      integer(kind(rocfft_array_type_complex_interleaved)),value :: out_array_type
      type(c_ptr),value :: in_offsets
      type(c_ptr),value :: out_offsets
      integer(c_size_t),value :: in_strides_size
      type(c_ptr),value :: in_strides
      integer(c_size_t),value :: in_distance
      integer(c_size_t),value :: out_strides_size
      type(c_ptr),value :: out_strides
      integer(c_size_t),value :: out_distance
    end function

#ifdef USE_FPOINTER_INTERFACES
    module procedure &
      rocfft_plan_description_set_data_layout_rank_0,&
      rocfft_plan_description_set_data_layout_rank_1
#endif
  end interface
  !>  @brief Get library version string
  !>
  !>  @param[in, out] buf buffer that receives the version string
  !>  @param[in] len length of buf, minimum 30 characters
  interface rocfft_get_version_string
    function rocfft_get_version_string_(buf,len) bind(c, name="rocfft_get_version_string")
      use iso_c_binding
      use hipfort_rocfft_enums
      implicit none
      integer(kind(rocfft_status_success)) :: rocfft_get_version_string_
      type(c_ptr),value :: buf
      integer(c_size_t),value :: len
    end function

  end interface
  !>  @brief Set devices in plan description
  !>   @details This is one of plan description functions to specify optional additional plan properties using the description handle. This API specifies what compute devices to target.
  !>   @param[in] description description handle
  !>   @param[in] devices array of device identifiers
  !>   @param[in] number_of_devices number of devices (size of devices array)
  interface rocfft_plan_description_set_devices
    function rocfft_plan_description_set_devices_(description,devices,number_of_devices) bind(c, name="rocfft_plan_description_set_devices")
      use iso_c_binding
      use hipfort_rocfft_enums
      implicit none
      integer(kind(rocfft_status_success)) :: rocfft_plan_description_set_devices_
      type(c_ptr),value :: description
      type(c_ptr),value :: devices
      integer(c_size_t),value :: number_of_devices
    end function

  end interface
  !>  @brief Get work buffer size
  !>   @details Get the work buffer size required for a plan.
  !>   @param[in] plan plan handle
  !>   @param[out] size_in_bytes size of needed work buffer in bytes
  interface rocfft_plan_get_work_buffer_size
    function rocfft_plan_get_work_buffer_size_(plan,size_in_bytes) bind(c, name="rocfft_plan_get_work_buffer_size")
      use iso_c_binding
      use hipfort_rocfft_enums
      implicit none
      integer(kind(rocfft_status_success)) :: rocfft_plan_get_work_buffer_size_
      type(c_ptr),value :: plan
      integer(c_size_t) :: size_in_bytes
    end function

  end interface
  !>  @brief Print all plan information
  !>   @details Prints plan details to stdout, to aid debugging
  !>   @param[in] plan plan handle
  interface rocfft_plan_get_print
    function rocfft_plan_get_print_(plan) bind(c, name="rocfft_plan_get_print")
      use iso_c_binding
      use hipfort_rocfft_enums
      implicit none
      integer(kind(rocfft_status_success)) :: rocfft_plan_get_print_
      type(c_ptr),value :: plan
    end function

  end interface
  !>  @brief Create plan description
  !>   @details This API creates a plan description with which the user
  !>  can set extra plan properties.  The plan description must be freed
  !>  with a call to ::rocfft_plan_description_destroy.
  !>   @param[out] description plan description handle
  interface rocfft_plan_description_create
    function rocfft_plan_description_create_(description) bind(c, name="rocfft_plan_description_create")
      use iso_c_binding
      use hipfort_rocfft_enums
      implicit none
      integer(kind(rocfft_status_success)) :: rocfft_plan_description_create_
      type(c_ptr) :: description
    end function

  end interface
  !>  @brief Destroy a plan description
  !>   @details This API frees the plan description.  A plan description
  !>   can be freed any time after it is passed to ::rocfft_plan_create.
  !>   @param[in] description plan description handle
  interface rocfft_plan_description_destroy
    function rocfft_plan_description_destroy_(description) bind(c, name="rocfft_plan_description_destroy")
      use iso_c_binding
      use hipfort_rocfft_enums
      implicit none
      integer(kind(rocfft_status_success)) :: rocfft_plan_description_destroy_
      type(c_ptr),value :: description
    end function

  end interface
  !>  @brief Create execution info
  !>   @details This API creates an execution info with which the user
  !>  can control plan execution and work buffers.  The execution info must be freed
  !>  with a call to ::rocfft_execution_info_destroy.
  !>   @param[out] info execution info handle
  interface rocfft_execution_info_create
    function rocfft_execution_info_create_(myInfo) bind(c, name="rocfft_execution_info_create")
      use iso_c_binding
      use hipfort_rocfft_enums
      implicit none
      integer(kind(rocfft_status_success)) :: rocfft_execution_info_create_
      type(c_ptr) :: myInfo
    end function

  end interface
  !>  @brief Destroy an execution info
  !>   @details This API frees the execution info.  An execution info
  !>   object can be freed any time after it is passed to
  !>   ::rocfft_execute.
  !>   @param[in] info execution info handle
  interface rocfft_execution_info_destroy
    function rocfft_execution_info_destroy_(myInfo) bind(c, name="rocfft_execution_info_destroy")
      use iso_c_binding
      use hipfort_rocfft_enums
      implicit none
      integer(kind(rocfft_status_success)) :: rocfft_execution_info_destroy_
      type(c_ptr),value :: myInfo
    end function

  end interface
  !>  @brief Set work buffer in execution info
  !>
  !>   @details This is one of the execution info functions to specify
  !>   optional additional information to control execution.  This API
  !>   provides a work buffer for the transform. It must be called
  !>   before ::rocfft_execute.
  !>
  !>   When a non-zero value is obtained from
  !>   ::rocfft_plan_get_work_buffer_size, that means the library needs a
  !>   work buffer to compute the transform. In this case, the user
  !>   should allocate the work buffer and pass it to the library via
  !>   this API.
  !>
  !>   If a work buffer is required for the transform but is not
  !>   specified using this function, ::rocfft_execute will automatically
  !>   allocate the required buffer and free it when execution is
  !>   finished.
  !>
  !>   Users should allocate their own work buffers if they need precise
  !>   control over the lifetimes of those buffers, or if multiple plans
  !>   need to share the same buffer.
  !>
  !>   @param[in] info execution info handle
  !>   @param[in] work_buffer work buffer
  !>   @param[in] size_in_bytes size of work buffer in bytes
  interface rocfft_execution_info_set_work_buffer
    function rocfft_execution_info_set_work_buffer_(myInfo,work_buffer,size_in_bytes) bind(c, name="rocfft_execution_info_set_work_buffer")
      use iso_c_binding
      use hipfort_rocfft_enums
      implicit none
      integer(kind(rocfft_status_success)) :: rocfft_execution_info_set_work_buffer_
      type(c_ptr),value :: myInfo
      type(c_ptr),value :: work_buffer
      integer(c_size_t),value :: size_in_bytes
    end function

  end interface
  !>  @brief Set execution mode in execution info
  !>   @details This is one of the execution info functions to specify optional additional information to control execution.
  !>   This API specifies execution mode. It has to be called before the call to rocfft_execute.
  !>   Appropriate enumeration value can be specified to control blocking/non-blocking behavior of the rocfft_execute call.
  !>   @param[in] info execution info handle
  !>   @param[in] mode execution mode
  interface rocfft_execution_info_set_mode
    function rocfft_execution_info_set_mode_(myInfo,mode) bind(c, name="rocfft_execution_info_set_mode")
      use iso_c_binding
      use hipfort_rocfft_enums
      implicit none
      integer(kind(rocfft_status_success)) :: rocfft_execution_info_set_mode_
      type(c_ptr),value :: myInfo
      integer(kind(rocfft_exec_mode_nonblocking)),value :: mode
    end function

  end interface
  !>  @brief Set stream in execution info
  !>   @details Associates an existing compute stream to a plan.  This
  !>  must be called before the call to ::rocfft_execute.
  !>
  !>   Once the association is made, execution of the FFT will run the
  !>   computation through the specified stream.
  !>
  !>   The stream must be of type hipStream_t. It is an error to pass
  !>   the address of a hipStream_t object.
  !>
  !>   @param[in] info execution info handle
  !>   @param[in] stream underlying compute stream
  interface rocfft_execution_info_set_stream
    function rocfft_execution_info_set_stream_(myInfo,stream) bind(c, name="rocfft_execution_info_set_stream")
      use iso_c_binding
      use hipfort_rocfft_enums
      implicit none
      integer(kind(rocfft_status_success)) :: rocfft_execution_info_set_stream_
      type(c_ptr),value :: myInfo
      type(c_ptr),value :: stream
    end function

  end interface
  !>  @brief Set a load callback for a plan execution (experimental)
  !>   @details This function specifies a user-defined callback function
  !>   that is run to load input from global memory at the start of the
  !>   transform.  Callbacks are an experimental feature in rocFFT.
  !>
  !>   Callback function pointers/data are given as arrays, with one
  !>   function/data pointer per device executing this plan.  Currently,
  !>   plans can only use one device.
  !>
  !>   The provided function pointers replace any previously-specified
  !>   load callback for this execution info handle.
  !>
  !>   Load callbacks have the following signature:
  !>
  !>   @code
  !>   T load_cb(T* data, size_t offset, void* cbdata, void* sharedMem);
  !>   @endcode
  !>
  !>   'T' is the type of a single element of the input buffer.  It is
  !>   the caller's responsibility to ensure that the function type is
  !>   appropriate for the plan (for example, a single-precision
  !>   real-to-complex transform would load single-precision real
  !>   elements).
  !>
  !>   A null value for 'cb' may be specified to clear any previously
  !>   registered load callback.
  !>
  !>   Currently, 'shared_mem_bytes' must be 0.  Callbacks are not
  !>   supported on transforms that use planar formats for either input
  !>   or output.
  !>
  !>   @param[in] info execution info handle
  !>   @param[in] cb callback function pointers
  !>   @param[in] cbdata callback function data, passed to the function pointer when it is called
  !>   @param[in] shared_mem_bytes amount of shared memory to allocate for the callback function to use
  interface rocfft_execution_info_set_load_callback
    function rocfft_execution_info_set_load_callback_(myInfo,cb_functions,cb_data,shared_mem_bytes) bind(c, name="rocfft_execution_info_set_load_callback")
      use iso_c_binding
      use hipfort_rocfft_enums
      implicit none
      integer(kind(rocfft_status_success)) :: rocfft_execution_info_set_load_callback_
      type(c_ptr),value :: myInfo
      type(c_ptr) :: cb_functions
      type(c_ptr) :: cb_data
      integer(c_size_t),value :: shared_mem_bytes
    end function

  end interface
  !>  @brief Set a store callback for a plan execution (experimental)
  !>   @details This function specifies a user-defined callback function
  !>   that is run to store output to global memory at the end of the
  !>   transform.  Callbacks are an experimental feature in rocFFT.
  !>
  !>   Callback function pointers/data are given as arrays, with one
  !>   function/data pointer per device executing this plan.  Currently,
  !>   plans can only use one device.
  !>
  !>   The provided function pointers replace any previously-specified
  !>   store callback for this execution info handle.
  !>
  !>   Store callbacks have the following signature:
  !>
  !>   @code
  !>   void store_cb(T* data, size_t offset, T element, void* cbdata, void* sharedMem);
  !>   @endcode
  !>
  !>   'T' is the type of a single element of the output buffer.  It is
  !>   the caller's responsibility to ensure that the function type is
  !>   appropriate for the plan (for example, a single-precision
  !>   real-to-complex transform would store single-precision complex
  !>   elements).
  !>
  !>   A null value for 'cb' may be specified to clear any previously
  !>   registered store callback.
  !>
  !>   Currently, 'shared_mem_bytes' must be 0.  Callbacks are not
  !>   supported on transforms that use planar formats for either input
  !>   or output.
  !>
  !>   @param[in] info execution info handle
  !>   @param[in] cb callbacks function pointers
  !>   @param[in] cbdata callback function data, passed to the function pointer when it is called
  !>   @param[in] shared_mem_bytes amount of shared memory to allocate for the callback function to use
  interface rocfft_execution_info_set_store_callback
    function rocfft_execution_info_set_store_callback_(myInfo,cb_functions,cb_data,shared_mem_bytes) bind(c, name="rocfft_execution_info_set_store_callback")
      use iso_c_binding
      use hipfort_rocfft_enums
      implicit none
      integer(kind(rocfft_status_success)) :: rocfft_execution_info_set_store_callback_
      type(c_ptr),value :: myInfo
      type(c_ptr) :: cb_functions
      type(c_ptr) :: cb_data
      integer(c_size_t),value :: shared_mem_bytes
    end function

  end interface
  !>  @brief Get events from execution info
  !>   @details This is one of the execution info functions to retrieve information from execution.
  !>   This API obtains event information. It has to be called after the call to rocfft_execute.
  !>   This gets handles to events that the library created around one or more kernel launches during execution.
  !>   @param[in] info execution info handle
  !>   @param[out] events array of events
  !>   @param[out] number_of_events number of events (size of events array)
  interface rocfft_execution_info_get_events
    function rocfft_execution_info_get_events_(myInfo,events,number_of_events) bind(c, name="rocfft_execution_info_get_events")
      use iso_c_binding
      use hipfort_rocfft_enums
      implicit none
      integer(kind(rocfft_status_success)) :: rocfft_execution_info_get_events_
      type(c_ptr),value :: myInfo
      type(c_ptr) :: events
      integer(c_size_t) :: number_of_events
    end function

  end interface
  !>  @brief Serialize compiled kernel cache
  !>
  !>   @details Serialize rocFFT's cache of compiled kernels into a
  !>   buffer.  This buffer is allocated by rocFFT and must be freed
  !>   with a call to ::rocfft_cache_buffer_free.  The length of the
  !>   buffer in bytes is written to 'buffer_len_bytes'.
  interface rocfft_cache_serialize
    function rocfft_cache_serialize_(buffer,buffer_len_bytes) bind(c, name="rocfft_cache_serialize")
      use iso_c_binding
      use hipfort_rocfft_enums
      implicit none
      integer(kind(rocfft_status_success)) :: rocfft_cache_serialize_
      type(c_ptr) :: buffer
      type(c_ptr),value :: buffer_len_bytes
    end function

  end interface
  !>  @brief Free cache serialization buffer
  !>
  !>   @details Deallocate a buffer allocated by ::rocfft_cache_serialize.
  interface rocfft_cache_buffer_free
    function rocfft_cache_buffer_free_(buffer) bind(c, name="rocfft_cache_buffer_free")
      use iso_c_binding
      use hipfort_rocfft_enums
      implicit none
      integer(kind(rocfft_status_success)) :: rocfft_cache_buffer_free_
      type(c_ptr),value :: buffer
    end function

  end interface
  !>  @brief Deserialize a buffer into the compiled kernel cache.
  !>
  !>   @details Kernels in the buffer that match already-cached kernels
  !>   will replace those kernels that are in the cache.  Already-cached
  !>   kernels that do not match those in the buffer are unmodified by
  !>   this operation.  The cache is unmodified if either a null buffer
  !>   pointer or a zero length is passed.
  interface rocfft_cache_deserialize
    function rocfft_cache_deserialize_(buffer,buffer_len_bytes) bind(c, name="rocfft_cache_deserialize")
      use iso_c_binding
      use hipfort_rocfft_enums
      implicit none
      integer(kind(rocfft_status_success)) :: rocfft_cache_deserialize_
      type(c_ptr),value :: buffer
      integer(c_size_t),value :: buffer_len_bytes
    end function

  end interface

#ifdef USE_FPOINTER_INTERFACES
  contains
    function rocfft_plan_create_rank_0(plan,placement,transform_type,myPrecision,dimensions,lengths,number_of_transforms,description)
      use iso_c_binding
      use hipfort_rocfft_enums
      implicit none
      integer(kind(rocfft_status_success)) :: rocfft_plan_create_rank_0
      type(c_ptr) :: plan
      integer(kind(rocfft_placement_inplace)) :: placement
      integer(kind(rocfft_transform_type_complex_forward)) :: transform_type
      integer(kind(rocfft_precision_single)) :: myPrecision
      integer(c_size_t) :: dimensions
      integer(c_size_t),target :: lengths
      integer(c_size_t) :: number_of_transforms
      type(c_ptr) :: description
      !
      rocfft_plan_create_rank_0 = rocfft_plan_create_(plan,placement,transform_type,myPrecision,dimensions,c_loc(lengths),number_of_transforms,description)
    end function

    function rocfft_plan_create_rank_1(plan,placement,transform_type,myPrecision,dimensions,lengths,number_of_transforms,description)
      use iso_c_binding
      use hipfort_rocfft_enums
      implicit none
      integer(kind(rocfft_status_success)) :: rocfft_plan_create_rank_1
      type(c_ptr) :: plan
      integer(kind(rocfft_placement_inplace)) :: placement
      integer(kind(rocfft_transform_type_complex_forward)) :: transform_type
      integer(kind(rocfft_precision_single)) :: myPrecision
      integer(c_size_t) :: dimensions
      integer(c_size_t),target,dimension(:) :: lengths
      integer(c_size_t) :: number_of_transforms
      type(c_ptr) :: description
      !
      rocfft_plan_create_rank_1 = rocfft_plan_create_(plan,placement,transform_type,myPrecision,dimensions,c_loc(lengths),number_of_transforms,description)
    end function

    function rocfft_plan_description_set_data_layout_rank_0(description,in_array_type,out_array_type,in_offsets,out_offsets,in_strides_size,in_strides,in_distance,out_strides_size,out_strides,out_distance)
      use iso_c_binding
      use hipfort_rocfft_enums
      implicit none
      integer(kind(rocfft_status_success)) :: rocfft_plan_description_set_data_layout_rank_0
      type(c_ptr) :: description
      integer(kind(rocfft_array_type_complex_interleaved)) :: in_array_type
      integer(kind(rocfft_array_type_complex_interleaved)) :: out_array_type
      integer(c_size_t),target :: in_offsets
      integer(c_size_t),target :: out_offsets
      integer(c_size_t) :: in_strides_size
      integer(c_size_t),target :: in_strides
      integer(c_size_t) :: in_distance
      integer(c_size_t) :: out_strides_size
      integer(c_size_t),target :: out_strides
      integer(c_size_t) :: out_distance
      !
      rocfft_plan_description_set_data_layout_rank_0 = rocfft_plan_description_set_data_layout_(description,in_array_type,out_array_type,c_loc(in_offsets),c_loc(out_offsets),in_strides_size,c_loc(in_strides),in_distance,out_strides_size,c_loc(out_strides),out_distance)
    end function

    function rocfft_plan_description_set_data_layout_rank_1(description,in_array_type,out_array_type,in_offsets,out_offsets,in_strides_size,in_strides,in_distance,out_strides_size,out_strides,out_distance)
      use iso_c_binding
      use hipfort_rocfft_enums
      implicit none
      integer(kind(rocfft_status_success)) :: rocfft_plan_description_set_data_layout_rank_1
      type(c_ptr) :: description
      integer(kind(rocfft_array_type_complex_interleaved)) :: in_array_type
      integer(kind(rocfft_array_type_complex_interleaved)) :: out_array_type
      integer(c_size_t),target,dimension(:) :: in_offsets
      integer(c_size_t),target,dimension(:) :: out_offsets
      integer(c_size_t) :: in_strides_size
      integer(c_size_t),target,dimension(:) :: in_strides
      integer(c_size_t) :: in_distance
      integer(c_size_t) :: out_strides_size
      integer(c_size_t),target,dimension(:) :: out_strides
      integer(c_size_t) :: out_distance
      !
      rocfft_plan_description_set_data_layout_rank_1 = rocfft_plan_description_set_data_layout_(description,in_array_type,out_array_type,c_loc(in_offsets),c_loc(out_offsets),in_strides_size,c_loc(in_strides),in_distance,out_strides_size,c_loc(out_strides),out_distance)
    end function

#endif
end module hipfort_rocfft

max_stars_repo_name: arvindcheru/hipfort

max_issues_repo_name: arvindcheru/hipfort

max_forks_repo_name: arvindcheru/hipfort


text:
C    Copyright(C) 1999-2020 National Technology & Engineering Solutions
C    of 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    See packages/seacas/LICENSE for details
      SUBROUTINE MXCOMP (MYV, VOID, LVOID,
     *   NVOIDS, DPOINT, LDICT, NNAMES, CHRCOL, LASTER)

      IMPLICIT INTEGER (A-Z)
      INCLUDE 'params.inc'

C     THIS ROUTINE PERFORMS THE NUMERIC DATA COMPRESSION OPERATION.

C************************************************************************

C     MYV      Reference array
C     VOID     Void table
C     LVOID    Dimension of VOID
C     NVOIDS   Number of voids
C     DPOINT   Dictionary pointer table
C     LDICT    Dimension of DPOINT
C     NNAMES   Number of names
C     CHRCOL   Column for character tables
C     LASTER   Error return code

      DIMENSION DPOINT(LDICT,CHRCOL,2), VOID(LVOID,CHRCOL,2), MYV(*)
      DIMENSION NNAMES(2), NVOIDS(2)

C************************************************************************

      LASTER = SUCESS

C     The basic strategy is to look for an array in the dictionary
C     which is immediately preceded by a void.  If found, a shift
C     is performed, and the void table is updated.

      IVOID = 0
  100 CONTINUE
      IVOID = IVOID + 1
  110 IF (IVOID .GT. NVOIDS(1)) GO TO 130
         VADDR = VOID(IVOID,1,1) + VOID(IVOID,1,2)
         DO 120 IDICT = 1, NNAMES(1)
            DADDR = DPOINT(IDICT,1,1)
            IF (VADDR .EQ. DADDR .AND. DPOINT(IDICT,1,2) .GT. 0) THEN

C              Perform data shift and update void table.

               CALL SHFTI (MYV, 1, 1,
     *            DADDR, DADDR+DPOINT(IDICT,1,2)-1, VOID(IVOID,1,2))
               DPOINT(IDICT,1,1) = VOID(IVOID,1,1)
               VOID(IVOID,1,1) = DPOINT(IDICT,1,1) + DPOINT(IDICT,1,2)
               CALL VTABLE (0, 0, VOID, LVOID, NVOIDS(1), CHRCOL,
     *            LASTER)
               IF (LASTER .NE. SUCESS) RETURN
               GO TO 110

            END IF
  120    CONTINUE
      GO TO 100
  130 CONTINUE
      RETURN
      END

max_stars_repo_name: jschueller/seacas

max_issues_repo_name: jschueller/seacas

max_forks_repo_name: jschueller/seacas