text:
C    @(#)redchgs.f	20.5 1/4/99
C****************************************************************
C
C   	File: redchgs.f
C
C   	Purpose: Reduce (consolidate) all changes for a single
C                data item in /OLDCHG/ into a single equivalent
C                change record.
C
C   	Author: Walt Powell            Date: 13 November 1992
C   	Called by: savechgs.f
C
C****************************************************************
C
      	subroutine redchgs (first, last)
        integer first, last

      	include 'ipfinc/parametr.inc'

      	include 'ipfinc/changr.inc'
      	include 'ipfinc/oldchg.inc'
      	include 'ipfinc/prt.inc'
      	include 'ipfinc/qksrt.inc'

        common /scratch/ array(MAXCHG), xndex(100)
        integer array, xndex

        integer kmpoldch, gtchgtyp
      	external kmpoldch, swpoldch, gtchgtyp

      	if (last .eq. 0 .or. last .gt. numold) go to 900
c
c       Set "key" to disable kmpoldch from breaking ties using
c       change index.
c
        key = 1
c
c       Reduce changes:
c
c       Add + Mod = Add'
c       Add + Del = both cancel
c       Add + Res = Illegal - program error
c       Mod + Mod = Mod'
c       Mod + Del = Del'
c       Mod + Add = Illegal - program error
c       Mod + Res = Illegal - program error
c       Del + Add = Mod'
c       Del + Res = both cancel
c       Del + Mod = Illegal - program error
c
        ix = 1
        do while (ix .le. numold)
           ic = array(ix)
           if (ic .lt. first .or. ic .gt. last) then
              ix = ix + 1
              go to 172
c
c             Exempt non-processed changes and change errors.
c
           else if (oldchg(ic)(126:126) .ne. 'P') then
              ix = ix + 1
              go to 172
           endif

           numc = 1
           xndex(numc) = ix
c
c          Look ahead for next change
c
           komptype = 0
           iy = ix + 1

           do while (iy .le. last .and. komptype .ge. 0)
              jc = array(iy)
              if (oldchg(jc)(126:126) .ne. 'P') then
                iy = iy + 1
                go to 112
              else if (jc .lt. first .or. jc .gt. last) then
                 iy = iy + 1
                 go to 112
              endif
              komptype = kmpoldch (ix, iy)
              if (komptype .lt. 0) then
              else if (komptype .gt. 0) then
                 write (errbuf(1), 100)
  100            format (' REDCHGS sort error - records :')
                 write (errbuf(2), 110) oldchg(ic)(122:125),
     1                                  oldchg(ic)(1:80)
  110            format ('   Change card no. ',a4,' (',a80,')')
                 write (errbuf(3), 110) oldchg(jc)(122:125),
     1                                  oldchg(jc)(1:80)
                 call prterx ('W', 3)
                 iy = iy + 1
              else
                 numc = numc + 1
                 xndex(numc) = iy
                 iy = iy + 1
              endif
  112         continue
           enddo

           if (numc .gt. 1) then

              ic = array(xndex(1))
              ictype = gtchgtyp (oldchg(ic)(1:2))
c
c             gtchgtyp = index ('/.DPZAIB+XQEL$$R$T', oldchg(ic)(1:1))
c
c                      /    .    d    p    z    a    i    b    +
c                      x    q    e    l   ld   lm    r   rz    t
              go to (170, 114, 170, 170, 170, 120, 120, 140, 140,
     1               140, 140, 150, 150, 150, 150, 150, 150, 150) ictype
c
c             Reduce ".#" comments
c
  114         call c_redchg (numc, xndex)
              go to 160
c
c             Reduce "A" through "A9" or "I" changes
c
  120         call a_redchg (numc, xndex)
              go to 160
c
c             Reduce "B", "+", or "X" changes
c
  140         call b_redchg (numc, xndex)
              go to 160
c
c             Reduce "E", "L", "LD", "LM", "R", "RZ", "T" changes
c
  150         call l_redchg (numc, xndex)

  160         continue
           endif

  170      ix = xndex(numc) + 1
  172      continue
        enddo

  900   continue

        return
        end

max_stars_repo_name: mbheinen/bpa-ipf-tsp

max_issues_repo_name: cuihantao/bpa-ipf-tsp

max_forks_repo_name: mbheinen/bpa-ipf-tsp


text:
       SUBROUTINE threshold(splthr)
C
c This routine passes the 1/3 octave band data in a common block, which could
c be changed so the data are passed in as parameters to fit in a more modular
c program.
c
c returns level weighted using the human threshold of hearing
c				BMS Feb 7 2003

c L=level (43 1/3 octave bands)
c SPL=calculated loudness level (calculated from L for bands 1 to 40)
      REAL*4 L(43),SPL
      COMMON /CRUX/ SPL,L

	real thrdb(29)
c	real hz(29), awt(31)
	real splthr, sum, now

c	data hz /
c     1  20.,     25.,     31.5,    40.,     50.,     63.,     80.,
c     1  100.,
c     2  125.,    160.,    200.,    250.,    315.,    400.,    500.,
c     2  630.,
c     3  800.,    1000.,   1250.,   1600.,   2000.,   2500.,   3150.,
c     3  4000.,
c     4  5000.,   6300.,   8000.,   10000.,  12500./

c Threshold from ISO ISO 266:1987E MAF (see ISO_threshold.xls)
       data thrdb /
     1   74.3, 65.0, 56.3, 48.4, 41.7, 35.5, 29.8, 25.1,
     2   20.7, 16.8, 13.8, 11.2, 8.9, 7.2, 6.0, 5.0,
     3   4.4, 4.2, 3.7, 2.6, 1.0, -1.2, -3.6, -3.9,
     4   -1.1, 6.6, 15.3, 16.4, 11.6 /

c the following is 0 phons, not MAF (threshold)
c     1  72.5283, 63.1014, 54.2712, 46.1848, 39.2837, 32.8897, 27.0421,
c     1  22.2560,
c     2  17.7767, 13.8101, 10.7624, 8.0990,  5.7027,  3.8784,  2.5284,
c     2  1.3147,
c     3  0.4533,  0.000,  -0.6507, -1.8672, -3.5252, -5.7230, -8.1034,
c     3  -8.3290,
c     4  -5.4224,  2.5104, 11.6117, 13.1107, 8.8396/

c	data awt / -50.4, -44.7, -39.2,
c     1  -34.6, -30.2, -26.1, -22.4, -19.1, -16.0, -13.3, -10.8,
c     2  -8.6, -6.6, -4.8, -3.2, -1.9, -0.8, 0.0, 0.6, 1.0, 1.2,
c     3  1.3, 1.2, 1.0, 0.6, -0.1, -1.1, -2.4, -4.3, -6.5, -9.2/

c  work with bands 13 to 41 (20Hz to 12.5kHz)

c	print *,hz
c	print *,thrdb
c	print *,awt

	sum = 0.0
	do i=13,41
            now = (L(i) - thrdb(i-12))
c	    now = (L(i) + awt(i-12))
c	    print *,hz(i-12),L(i),now
	    sum = sum + 10.**(now/10.)
	enddo

	splthr = 10. * alog10(sum)

	print *,splthr

         RETURN
         END

ext: f

max_stars_repo_name: mandalin/DissertationPostProcessing

max_issues_repo_name: mandalin/DissertationPostProcessing

max_forks_repo_name: mandalin/DissertationPostProcessing


text:
      program prog
      common /com/ num
      write(6, *) num
      end


! { dg-do compile }
! { dg-additional-options "-Wuninitialized" }

subroutine test
  integer, pointer :: p

  !$acc host_data use_device(p) ! { dg-warning "is used uninitialized in this function" }
  !$acc end host_data
end subroutine test


text:
C
C $Id: tdstri.f,v 1.4 2008-07-27 00:17:33 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE TDSTRI (U,NU,V,NV,W,LW1D,RTRI,MTRI,NTRI,IRST)
C
        DIMENSION U(NU),V(NV),W(LW1D,*),RTRI(10,MTRI)
C
C The routine TDSTRI, given a two-dimensional array of function values,
C generates a set of triangles representing the surface defined by those
C values and adds them to a list of triangles tendered by the user.  The
C arguments are as follows:
C
C   U is an input array of real values of the independent variable U.
C
C   NU is an input integer specifying the dimension of the array U.
C
C   V is an input array of real values of the independent variable V.
C
C   NV is an input integer specifying the dimension of the array V.
C
C   W is the two-dimensional real array of function values.  For each
C   I from 1 to NU and for each J from 1 to NV, (U(I),V(J),W(I,J)) is
C   a point on the surface represented by the arrays U, V, and W.
C
C   LW1D is an input integer specifying the first (FORTRAN) dimension of
C   the array W.  It must be the case that LW1D is greater than or equal
C   to NU.
C
C   RTRI is a real array in which a list of triangles is being
C   generated; it is dimensioned 10 x MTRI.  Each 10-word entry in
C   the list consists of the U, V, and W coordinates of each of three
C   points, followed by a rendering style index.
C
C   MTRI is an input integer specifying the second dimension of the
C   array RTRI: the maximum number of triangles the list will hold.
C
C   NTRI is an input/output integer specifying the number of triangles
C   currently in the array RTRI.  Initially, NTRI must be zeroed by the
C   user.  Each call to one of the routines TDSTRI or TDITRI updates the
C   value of NTRI to reflect the number of triangles added to the list.
C
C   IRST is an input integer specifying the rendering style index to be
C   used for all the triangles generated by a particular call to TDSTRI.
C   Note that more than one surface can be represented by the triangles
C   in the triangle list and that each surface can be rendered in its
C   own particular style.
C
C Get the real equivalent of the rendering style index.
C
        RRST=REAL(IRST)
C
C Loop through the grid boxes, generating two triangles apiece.  Note
C that each triangle is traced in a counterclockwise direction as
C viewed from above; this is important, as it enables the renderer to
C tell which side of a triangle is being looked at.
C
        DO 102 I=1,NU-1
          DO 101 J=1,NV-1
            IF (NTRI.LT.MTRI) THEN
              NTRI=NTRI+1
              RTRI(1,NTRI)=U(I)
              RTRI(2,NTRI)=V(J+1)
              RTRI(3,NTRI)=W(I,J+1)
              RTRI(4,NTRI)=U(I)
              RTRI(5,NTRI)=V(J)
              RTRI(6,NTRI)=W(I,J)
              RTRI(7,NTRI)=U(I+1)
              RTRI(8,NTRI)=V(J)
              RTRI(9,NTRI)=W(I+1,J)
              RTRI(10,NTRI)=RRST
            END IF
            IF (NTRI.LT.MTRI) THEN
              NTRI=NTRI+1
              RTRI(1,NTRI)=U(I+1)
              RTRI(2,NTRI)=V(J)
              RTRI(3,NTRI)=W(I+1,J)
              RTRI(4,NTRI)=U(I+1)
              RTRI(5,NTRI)=V(J+1)
              RTRI(6,NTRI)=W(I+1,J+1)
              RTRI(7,NTRI)=U(I)
              RTRI(8,NTRI)=V(J+1)
              RTRI(9,NTRI)=W(I,J+1)
              RTRI(10,NTRI)=RRST
            END IF
  101     CONTINUE
  102   CONTINUE
C
C Done.
C
        RETURN
C
      END

max_stars_repo_name: tenomoto/ncl

max_issues_repo_name: tenomoto/ncl

max_forks_repo_name: tenomoto/ncl


text:
      subroutine orthoapproxmatmonic(nsuccess)

      implicit real *8 (a-h,o-z)
      real *8 uvs(2,10000),wts(10000)
      real *8, allocatable :: x(:),y(:),w(:),basis_jk(:),basiskl(:)
      real *8, allocatable :: a_diag(:),vals2coefs(:,:)
      real *8, allocatable :: coefs2coefs(:,:)
      real *8, allocatable :: o_basis(:,:),p_coefs(:,:)
      real *8 nrm_kl ! numerator
      integer aorder,idx_jk,idx_jk_new
      integer add_power(2),power_x_new,power_y_new
      integer, allocatable :: o_basis_tile(:,:), tile_to_idx(:)
      integer, allocatable :: power_x(:), power_y(:)
      integer, allocatable :: xpower(:), ypower(:)

      nsuccess = 1

      aorder = 8
      norder = 8
      npols = (norder+1)*(norder+2)/2

      allocate(x(npols),y(npols),w(npols),basis_jk(npols))
      allocate(o_basis(aorder*(aorder+1)/2,npols))
      allocate(p_coefs(aorder*(aorder+1)/2,aorder*(aorder+1)/2))
      allocate(o_basis_tile(aorder,aorder))
      allocate(tile_to_idx(aorder*(aorder+1)/2))
      allocate(a_diag(aorder*(aorder+1)/2))
      allocate(vals2coefs(aorder*(aorder+1)/2,npols))
      allocate(coefs2coefs(aorder*(aorder+1)/2,aorder*(aorder+1)/2))
      allocate(power_x(aorder**2),power_y(aorder**2))
      allocate(xpower(aorder*(aorder+1)/2),ypower(aorder*(aorder+1)/2))

      call get_vioreanu_nodes(norder,npols,uvs)
      call get_vioreanu_wts(norder,npols,wts)
      x = uvs(1,1:npols)
      y = uvs(2,1:npols)
      w = wts(1:npols)
      o_basis = 1.0
      p_coefs = 0.0
      do i = 1,aorder*(aorder+1)/2
          p_coefs(i,i) = 1.0
      end do
      o_basis_tile(1,1) = 1
      tile_to_idx(1) = 1
      do j = 2,aorder
          do k = 1,j
              if (k .lt. j) then
                  basis_jk = x*o_basis(j*(j-1)/2+k-j+1,:)
              else
                  basis_jk = y*o_basis(j*(j-1)/2,:)
              end if
              o_basis(j*(j-1)/2+k,:) = basis_jk
              o_basis_tile(k,j-k+1) = j*(j-1)/2+k;
              tile_to_idx(j*(j-1)/2+k) = (j-k)*aorder+k;
          end do
          do k = j*(j-1)/2+1,j*(j+1)/2
              do l = 1,k-1
                  nrm_kl = sum(o_basis(k,:)*o_basis(l,:)*w)
                  p_coefs(l,k) = -nrm_kl/sum(o_basis(l,:)**2.*w)
              end do
              basiskl = matmul(transpose(o_basis(1:k,:)),p_coefs(1:k,k))
              o_basis(k,:) = basiskl
          end do
      end do

      a_diag = matmul(o_basis**2,w)
      do i = 1,aorder*(aorder+1)/2
        vals2coefs(i,:) = o_basis(i,:)*w/a_diag(i)
      end do

      coefs2coefs = 0.0
      do i = 1,aorder*(aorder+1)/2
          coefs2coefs(i,i) = 1.0
      end do
      power_x=reshape(spread((/(i,i=0,aorder-1)/),1,aorder),[aorder**2])
      power_y=reshape(spread((/(i,i=0,aorder-1)/),2,aorder),[aorder**2])
      do j = 1,aorder
          do k = j*(j-1)/2+1,j*(j+1)/2
              if (k .lt. j*(j+1)/2) then
                  idx_jk = k-j+1
                  add_power = (/1,0/)
              else
                  idx_jk = k-j
                  add_power = (/0,1/)
              end if
              do l = 1,idx_jk
                  power_x_new = power_x(tile_to_idx(l))+add_power(1)
                  power_y_new = power_y(tile_to_idx(l))+add_power(2)
                  idx_jk_new = o_basis_tile(power_y_new+1,power_x_new+1)
                  coefs2coefs(idx_jk_new,k) = coefs2coefs(l,idx_jk)
              end do
          coefs2coefs(1:k,k)=matmul(coefs2coefs(1:k,1:k),p_coefs(1:k,k))
          end do
      end do

      ! eval
      xpower = power_x(tile_to_idx); ypower = power_y(tile_to_idx);

      !
      open(2, file = '../orthomat.txt')
      do i = 1,aorder*(aorder+1)/2
          write(2,*) coefs2coefs(i,:)
      end do
      close(2)

      end


!----------------------------------------------------------------------
!----------------------------------------------------------------------
!   r3b :    The Restricted 3-Body Problem
!----------------------------------------------------------------------
!----------------------------------------------------------------------

 SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
!---------- ----

   IMPLICIT NONE
   INTEGER, INTENT(IN) :: NDIM, IJAC, ICP(*)
   DOUBLE PRECISION, INTENT(IN) :: U(NDIM), PAR(*)
   DOUBLE PRECISION, INTENT(OUT) :: F(NDIM)
   DOUBLE PRECISION, INTENT(INOUT) :: DFDU(NDIM,*), DFDP(NDIM,*)

   DOUBLE PRECISION x,y,z,xp,yp,zp,rl,rmu,dE,dM,rmc,dE3,dM3

   x  = U(1)
   y  = U(2)
   z  = U(3)
   xp = U(4)
   yp = U(5)
   zp = U(6)

   rl  = PAR(1)
   rmu = PAR(2)

   dE  = SQRT((x+rmu)**2 + y**2 + z**2)
   dM  = SQRT( (x-1+rmu)**2 + y**2 + z**2 )
   rmc = 1 - rmu
   dE3 = 1./dE**3
   dM3 = 1./dM**3

   F(1)= xp
   F(2)= yp
   F(3)= zp
   F(4)= 2*yp + x - rmc*dE3*(x+rmu) - rmu*dM3*(x-1+rmu) + rl*xp
   F(5)=-2*xp + y - rmc*dE3*y       - rmu*dM3*y         + rl*yp
   F(6)=          - rmc*dE3*z       - rmu*dM3*z         + rl*zp

 END SUBROUTINE FUNC
!----------------------------------------------------------------------
 SUBROUTINE STPNT(NDIM,U,PAR,T)
!---------- -----

   IMPLICIT NONE
   INTEGER, INTENT(IN) :: NDIM
   DOUBLE PRECISION, INTENT(INOUT) :: U(NDIM), PAR(*)
   DOUBLE PRECISION, INTENT(IN) :: T

   DOUBLE PRECISION rl,rmu

   rl  =  0.
   rmu =  0.

   PAR(:2) = (/ rl, rmu /)

   U = (/ 0.14107D0, 0.99D0, 0D0, 0D0, 0D0, 0D0 /)

 END SUBROUTINE STPNT
!----------------------------------------------------------------------
 SUBROUTINE PVLS(NDIM,U,PAR)
!---------- ----

   IMPLICIT NONE
   INTEGER, INTENT(IN) :: NDIM
   DOUBLE PRECISION, INTENT(IN) :: U(NDIM)
   DOUBLE PRECISION, INTENT(INOUT) :: PAR(*)

   DOUBLE PRECISION GETP,rmu,x,y,z,xp,yp,zp,d1,d2,EU,E,realfm,imagfm,ncmplx
   DOUBLE PRECISION routh,pi
   INTEGER i,j

   rmu = PAR(2)

   x  = U(1)
   y  = U(2)
   z  = U(3)
   xp = U(4)
   yp = U(5)
   zp = U(6)

   d1 = SQRT((x+rmu)**2 + y**2 + z**2)
   d2 = SQRT( (x-1+rmu)**2 + y**2 + z**2 )

   EU = (x**2 + y**2)/2 + (1-rmu)/d1 + rmu/d2
   E  = (xp**2 + yp**2 + zp**2)/2 - EU - rmu*(1-rmu)/2
   PAR(3) = E
   PAR(16)=y

! Maximum real Floquet multiplier: PAR(4)
! If there are two real multipliers with absolute value > 1
! then PAR(4)=0.

   PAR(4) = 0
   ncmplx = 0
   DO i=1,NDIM
      imagfm = GETP('EIG',I*2,U)
      IF (imagfm == 0) THEN
         realfm = GETP('EIG',I*2-1,U)
         IF (ABS(realfm) > ABS(PAR(4))) THEN
            PAR(4) = realfm
         ENDIF
      ELSE
         ncmplx = ncmplx + 1
      ENDIF
   ENDDO
   IF (ncmplx == 0) THEN
      ! no complex multipliers mean 6 real multipliers: 1,1, two with
      ! absolute value greater than 1 and two less than one
      PAR(4) = 0
   ELSEIF (ncmplx == 4) THEN
      ! all non-trivial multipliers complex: must be 1 without rounding
      ! errors
      PAR(4) = 1
   ENDIF

!  Put purely imaginary eigenvalues in PAR(5), PAR(6) and PAR(7)

   j=1
   PAR(5) = 0
   PAR(6) = 0
   PAR(7) = 0
   pi = 4*ATAN(1d0)
   DO i=1,NDIM
      imagfm = GETP('EIG',I*2,U)
      IF (imagfm > 1d-5) THEN
         realfm = GETP('EIG',I*2-1,U)
         routh = 0.5d0*(1d0-sqrt(69d0)/9d0)
         ! above Routh's ratio we have one period for L4/L5, otherwise 3.
         IF (ABS(realfm) < EPSILON(1d0) .OR. rmu < routh .OR. ABS(y) < 0.1) THEN
            PAR(4+j) = 2*pi/imagfm
            j=j+1
         ENDIF
      ENDIF
   ENDDO

 END SUBROUTINE PVLS
!----------------------------------------------------------------------
!----------------------------------------------------------------------
 SUBROUTINE BCND
 END SUBROUTINE BCND

 SUBROUTINE ICND
 END SUBROUTINE ICND

 SUBROUTINE FOPT
 END SUBROUTINE FOPT
!----------------------------------------------------------------------
!----------------------------------------------------------------------


text:
The Yolo County Elections office is responsible for city, county, state and national elections for Yolo County, including elections for board of education boards of education and community colleges community college governance boards.  The County Clerk Reporter, Ms. Freddie Oakley, oversees the office.

The office is not involved with ASUCD Elections.

 2008 Presidential Election Early Voting
The office is open for early voting for Yolo County registered voters until Monday, November 3rd, on weekdays from 8am to 5pm.

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


!
! to create a python usable module:
! f2py -c -m <module_name> <file_name>.f90--->	f2py -c -m read_ops_bcs read_bin.f90
! to create a signature file:
! f2py -h <module_name>.pyf <file_name>.f90-->  f2py -h read_ops_bcs.pyf read_bin.f90
! .....................................................................
   SUBROUTINE read_bin_data( fileName, nymd_in, nymd_out, NLON, NLAT, LON, LAT, bcs_field)

   IMPLICIT NONE

   CHARACTER (LEN = 200), INTENT(IN)  :: fileName
   INTEGER,               INTENT(IN)  :: nymd_in

   INTEGER,               INTENT(OUT) :: nymd_out
   INTEGER,               INTENT(OUT) :: NLON
   INTEGER,               INTENT(OUT) :: NLAT

   REAL,                  INTENT(OUT) :: LON(2880)
   REAL,                  INTENT(OUT) :: LAT(1440)
   REAL,                  INTENT(OUT) :: bcs_field(1440, 2880)

! LOCAL VARS
   real    year1,month1,day1,hour1,min1,sec1
   real    year2,month2,day2,hour2,min2,sec2
   real    dum1,dum2
   real    dLat,dLon
   real    field(2880,1440)

   integer nymd1,nhms1
   integer nymd2,nhms2

   integer rc, ix
!  ....................................................................

!     print *, 'nymd_in=', nymd_in

      open (10,file=fileName,form='unformatted',access='sequential', STATUS = 'old')
!     ....................................................................
      rc = 0
      do while (rc.eq.0)
         ! read header
         read (10,iostat=rc)  year1,month1,day1,hour1,min1,sec1,                            &
                              year2,month2,day2,hour2,min2,sec2,dum1,dum2
         if( rc.eq.0 ) then
           read (10,iostat=rc)  field

           NLON  = nint(dum1)
           NLAT  = nint(dum2)
           IF( (NLON /= 2880) .or. (NLAT /= 1440)) THEN
              PRINT *, 'ERROR in LAT/LON dimension in file: ', fileName, 'NLON=', NLON, 'NLAT=', NLAT
              EXIT
           END IF
           dLat = 180./NLAT
           dLon = 360./NLON

           ! start date
           nymd1 = nint( year1*10000 )  + nint (month1*100)  +  nint( day1 )
           nhms1 = nint( hour1*10000 )  + nint (  min1*100)  +  nint( sec1 )

           ! end date
           nymd2 = nint( year2*10000 )  + nint (month2*100)  +  nint( day2 )
           nhms2 = nint( hour2*10000 )  + nint (  min2*100)  +  nint( sec2 )
         end if

         if (nymd1 .eq. nymd_in) then
            nymd_out = nymd1

!           print *, 'nymd_out=', nymd_out
!!          print *, bcs_field

            LAT(1) = -90. + dLat/2.
            DO ix = 2, NLAT
              LAT(ix) = LAT(ix-1) + dLat
            END DO

            LON(1) = -180. + dLon/2.
            DO ix = 2, NLON
              LON(ix) = LON(ix-1) + dLon
            END DO

            bcs_field = TRANSPOSE(field)
            close(10)
            RETURN
         end if
      end do
!     ....................................................................
      close(10)

!     print *, year1,month1,day1,hour1,min1,sec1
!     print *, year2,month2,day2,hour2,min2,sec2,dum1,dum2
!     print *, 'rc = ', rc
!---------------------------------------------------------------------------
    END SUBROUTINE read_bin_data
! .....................................................................
!


text:
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!                                                                                !!
!!  This file is part of SciFT project                                               !!
!!  Copyright (c) 2010-2014 Nestor F. Aguirre (nfaguirrec@gmail.com)                 !!
!!                                                                                !!
!!  Redistribution and use in source and binary forms, with or without               !!
!!  modification, are permitted provided that the following conditions are met:      !!
!!                                                                                !!
!!  1. Redistributions of source code must retain the above copyright notice, this   !!
!!     list of conditions and the following disclaimer.                              !!
!!  2. Redistributions in binary form must reproduce the above copyright notice,     !!
!!     this list of conditions and the following disclaimer in the documentation     !!
!!     and/or other materials provided with the distribution.                        !!
!!  3. Neither the name of the copyright holders nor the names of its contributors   !!
!!     may be used to endorse or promote products derived from this software         !!
!!     without specific prior written permission.                                    !!
!!                                                                                !!
!!  The copyright holders provide no reassurances that the source code provided      !!
!!  does not infringe any patent, copyright, or any other intellectual property      !!
!!  rights of third parties.  The copyright holders disclaim any liability to any    !!
!!  recipient for claims brought against recipient by any third party for            !!
!!  infringement of that parties intellectual property rights.                       !!
!!                                                                                !!
!!  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND  !!
!!  ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED    !!
!!  WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE           !!
!!  DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR  !!
!!  ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES   !!
!!  (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;     !!
!!  LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND      !!
!!  ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT       !!
!!  (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS    !!
!!  SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.                     !!
!!                                                                                !!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

module Morse_
	use IOStream_
	use UnitsConverter_
	use Grid_
	use RNFunction_
	use ThrularNumerovMethod_
	implicit none
	private

	public :: &
		Morse_test

	type, public, extends( RNFunction ):: Morse
		real(8) :: De
		real(8) :: alpha
		real(8) :: Re

		contains
			generic :: init => initDefaultMorse
			procedure :: initDefaultMorse
			procedure :: fromExp
			procedure :: destroy
			procedure :: parent
			procedure :: exactEigenValues
			procedure :: str
			procedure :: show
			procedure :: evaluate
	end type Morse

	contains

	!>
	!! @brief Constructor
	!!
	subroutine initDefaultMorse( this, rGrid, Re, De, alpha )
		class(Morse) :: this
		type(Grid), intent(in) :: rGrid
		real(8), intent(in) :: Re
		real(8), intent(in) :: De
		real(8), intent(in) :: alpha

		integer :: i
		real(8) :: r
		real(8), allocatable :: V(:)

		this.De = De
		this.alpha = alpha
		this.Re = Re

		allocate( V(rGrid.nPoints) )
		do i=1,rGrid.nPoints
			V(i) = this.evaluate( rGrid.data(i) )
		end do

		call this.fromGridArray( rGrid, V )
		deallocate( V )
	end subroutine initDefaultMorse

	!>
	!! @brief Constructor
	!! De = 0.25*ωe²/ωexe
	!! α = (ωe/ħ)*sqrt(m/2De)
	!!
	subroutine fromExp( this, rGrid, Re, we, wexe, rMass )
		class(Morse) :: this
		type(Grid), intent(in) :: rGrid
		real(8), intent(in) :: Re
		real(8), intent(in) :: we
		real(8), intent(in) :: wexe
		real(8), intent(in) :: rMass

		integer :: i
		real(8) :: r
		real(8), allocatable :: V(:)

		this.Re = Re
		this.De = 0.25_8*we**2.0_8/wexe
		this.alpha = we*sqrt(0.5*rMass/this.De)

		allocate( V(rGrid.nPoints) )
		do i=1,rGrid.nPoints
			V(i) = this.evaluate( rGrid.data(i) )
		end do

		call this.fromGridArray( rGrid, V )
		deallocate( V )
	end subroutine fromExp

	!>
	!! @brief Destructor
	!!
	subroutine destroy( this )
		class(Morse) :: this

	end subroutine destroy

	!>
	!! @brief Convert the object in its
	!!        parent object
	!!
	function parent( this ) result( output )
		class(Morse) :: this
		type(RNFunction) :: output

		call output.fromGridArray( this.xGrid, this.fArray )
	end function parent

	!>
	!! @brief String representation of
	!!        the object
	!!
	function str( this ) result( output )
		class(Morse) :: this
		character(len=200) :: output

		integer :: fmt
		character(len=200) :: strBuffer

		output = ""

		write(strBuffer, "(a)") "<Morse:"
		output = trim(output)//trim(strBuffer)

		output = trim(output)//"Re="
		fmt = int(log10(this.Re+1.0))+1
		write(strBuffer, "(f<fmt+7>.6)") this.Re
		output = trim(output)//trim(strBuffer)

		output = trim(output)//",De="
		fmt = int(log10(this.De+1.0))+1
		write(strBuffer, "(f<fmt+7>.6)") this.De
		output = trim(output)//trim(strBuffer)

		output = trim(output)//",alpha="
		fmt = int(log10(this.alpha+1.0))+1
		write(strBuffer, "(f<fmt+7>.6)") this.alpha
		output = trim(output)//trim(strBuffer)

		output = trim(output)//">"
	end function str

	!>
	!! @brief Write the string
	!! representation of the object in a
	!! selected unit
	!!
	subroutine show( this, unit )
		class(Morse) :: this
		integer, optional, intent(in) :: unit

		integer :: effunit

		if( present(unit) ) then
			effunit = unit
		else
			effunit = 6
		end if

		write(effunit,"(a)") trim(this.str())
	end subroutine show

	!>
	!! @brief Evaluates the function
	!! @param r
	!!
	function evaluate( this, r ) result( output )
		class( Morse ), intent(in) :: this
		real(8), intent(in) :: r
		real(8) :: output

		output = this.De*( exp(2.0_8*this.alpha*(this.Re-r)) &
					- 2.0_8*exp(this.alpha*(this.Re-r)) )
	end function evaluate

	!>
	!! @brief Returns the eigenvalue with the
	!!        quantum number as nu
	!!
	function exactEigenValues( this, nu, rMass ) result( output )
		class( Morse ), intent(in) :: this
		integer, intent(in) :: nu
		real(8), intent(in) :: rMass
		real(8) :: output

		real(8) :: we
		real(8) :: wexe

		we = this.alpha*sqrt(2.0_8*this.De/rMass)
		wexe = 0.25_8*we**2.0_8/this.De

		output = we*(dble(nu)+0.5_8)-wexe*(dble(nu)+0.5_8)**2.0_8-this.De
	end function exactEigenValues

	!>
	!! @brief Write the string
	!! representation of the object in a
	!! selected unit
	!!
	subroutine Morse_test()
		real(8) :: Re, we, wexe, rMass
		type(Morse) :: morse
		type(Grid) :: rGrid
		type(ThrularNumerovMethod) :: solver
		type(RNFunction) :: nf
		type(OFStream) :: ofile
		integer :: i ! dummy variable

		!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
		!! Cl2 X¹Σg+
		!! NIST Standard Reference Data Program
		!! -------------------------------------
		!! re    = 1.9879 Å
		!! ωe    = 559.72 cm⁻¹
		!! ωexe  = 2.675 cm⁻¹
		!! m(Cl) = 35.4257 amu
		!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
		Re = 1.9879_8*angs
		we = 559.72_8*cm1
		wexe = 2.675_8*cm1
		rMass = 0.5_8*35.4257_8*amu

		call rGrid.init( 0.5_8, 20.0_8, 10000 )
		call morse.fromExp( rGrid, Re, we, wexe, rMass )
		call morse.show()

		call solver.init( morse.parent(), 10, rMass )
		call solver.run()

		write(*,"(a5,a20,a20)") "\nu", "exact", "numeric"
		do i=1,solver.nStates
			if ( solver.eigenValues(i) < 0.0_8 ) then
					write(*,"(i5,f20.10,f20.10)") i, morse.exactEigenValues(i-1, rMass), solver.eigenValues(i)
			end if
		end do

		call solver.eigenFunctions(7).save( "salida" )

		call morse.destroy()
		call solver.destroy()

	end subroutine Morse_test

end module Morse_

max_stars_repo_name: nfaguirrec/scift


text:
! Test generic interfaces declared in modules.
! We used to get the name mangling wrong for these.
module module_interface_2
  interface foo
    subroutine myfoo (i)
      integer i
    end subroutine
    module procedure bar
  end interface
contains
subroutine bar (r)
  real r

  if (r .ne. 1.0) call abort ()
end subroutine
end module

subroutine myfoo (i)
  integer i

  if (i .ne. 42) call abort ()
end subroutine

program test
  use module_interface_2

  call foo (42)
  call foo (1.0)
end program

max_issues_repo_name: vidkidz/crossbridge

max_forks_repo_name: vidkidz/crossbridge


text:
! ------------------------------------------------------ !
! Bubel - strange_graphene.f90 - Krzysztof Kolasinski 2015
!
! Graphene unit cell consists of two atoms A and B, those
! atoms can be viewed as a two spin states of some quantum
! object. In that case Graphene lattice can be presented
! as a simple square lattice with propper coupling between
! nearest neightbours.
! ------------------------------------------------------ !

program graphen

use modunits    ! unit conversion tools
use modscatter  ! eigen values and transport
use modlead     ! bandgap structure
use modshape
implicit none
character(*),parameter :: output_folder = "strange_graphene_output/"
type(qscatter)             :: qt
type(qshape)               :: lead_shape

doubleprecision            :: zeros_vector(200)
doubleprecision            :: a_dx,a_Emin,a_Emax
integer                    :: no_expected_states
integer ,parameter         :: nx = 50
integer ,parameter         :: ny = 15
doubleprecision,parameter  :: dx = 5.0 ! [nm]
doubleprecision,parameter  :: alpha30 =  30.0/180.0*M_PI

integer , dimension(nx,ny) :: gindex ! converts local index (i,j) to global index
integer :: i,j,k,m
doubleprecision            :: lead_translation_vec(3),x,y,z,Ef
character(300) :: line

!QSYS_FORCE_SCHUR_DECOMPOSITION = .true.
! Initalize system
call qt%init_system()
! ----------------------------------------------------------
! 1. Create mesh - loop over width and height of the lattice
! ----------------------------------------------------------
k      = 0
gindex = 0
do i = 1 , nx
do j = 1 , ny
    ! Initalize atom structure with position of the atom. Now instead of atoms A and B we have
    ! one atom with two spins.
    call qt%qatom%init((/ (i-1) * dx , (j-1) * dx + (i-1) * dx * 0.0 , 0.0 * dx /),no_in_states=2)
    ! Add atom to the system.
    call qt%qsystem%add_atom(qt%qatom)
    k           = k + 1
    gindex(i,j) = k
enddo
enddo
! ----------------------------------------------------------
! 2. Construct logical connections between sites on the mesh.
! ----------------------------------------------------------
qt%qnnbparam%box = (/2*dx,2*dx,0.0D0/)
call qt%qsystem%make_lattice(qt%qnnbparam,c_matrix=coupling)

! ----------------------------------------------------------
! 3. Find eigenvalues of the system.
! You must provide range of energy (Emin,Emax) and
! number of expected states in that region. Eigen problem
! is solved with FEAST library.
! ----------------------------------------------------------
no_expected_states = 40
! we choose small window
a_Emin =-3.0+0.1
a_Emax =-2.9+0.1
call qt%qsystem%calc_eigenproblem(a_Emin,a_Emax,no_expected_states)

! Write founded eigenstates to file if there are states in the range (Emin,Emax)
if(qt%qsystem%no_eigenvalues > 0) then
zeros_vector = 0
open(unit=222,file=output_folder//"eigenvecs.dat")
do i = 1 , nx
do j = 1 , ny
    ! Remapping to graphen lattice
    x = (qt%qsystem%atoms(gindex(i,j))%atom_pos(1) + qt%qsystem%atoms(gindex(i,j))%atom_pos(2)*sin(alpha30))/dx
    y = (qt%qsystem%atoms(gindex(i,j))%atom_pos(2) - sin(alpha30)*qt%qsystem%atoms(gindex(i,j))%atom_pos(1))/dx
    z = 0
    if(qt%qsystem%atoms(gindex(i,j))%bActive)then
        ! get unique ID of current site
        k = qt%qsystem%atoms(gindex(i,j))%globalIDs(2)  ! spin = 2
        m = qt%qsystem%atoms(gindex(i,j))%globalIDs(1)  ! spin = 1
        write(222,"(500e20.6)"),x,y,z,abs(qt%qsystem%eigenvecs(k,:))**2+abs(qt%qsystem%eigenvecs(m,:))**2
    else
        ! fill with zeros empty spaces
        write(222,"(500e20.6)"),x,y,z,zeros_vector(1:qt%qsystem%no_eigenvalues)
    endif
enddo
write(222,*),"" ! GNUPLOT necessary line break
enddo
close(222)
endif ! end of if are there eigenstates?

! ----------------------------------------------------------
! 4. Use generated mesh to calculate the band structure
! in the region of homogenous lead.
! ----------------------------------------------------------
! Setup shape and initialize lead
lead_translation_vec = (/  dx , 0.0D0 , 0.0D0 /)
call lead_shape%init_range_3d((/ -0.5*dx , 0.0D0 , 0.0D0 /),lead_translation_vec)
call qt%add_lead(lead_shape,lead_translation_vec)

lead_translation_vec = (/  -dx , 0.0D0 , 0.0D0 /)
call lead_shape%init_range_3d((/ (nx+0.5-1)*dx , 0.0D0 , 0.0D0 /),lead_translation_vec)
call qt%add_lead(lead_shape,lead_translation_vec)

a_Emin =-3.0
a_Emax = 3.0
call qt%leads(1)%bands(output_folder//"bands.dat",-M_PI,+M_PI,M_PI/160.0,a_Emin,a_Emax)

! Save lattice to file to see if constructed system is OK!
call qt%save_system(output_folder//"system.xml")

Ef = 0.1
QSYS_DEBUG_LEVEL = 1 ! tell me more
call qt%calculate_modes(Ef)
call qt%solve(1,Ef)

! Save calculated electron density to file
do i = 1 , size(qt%qauxvec)
    qt%qauxvec(i) = sum(qt%densities(:,i))
enddo
call qt%qsystem%save_data(output_folder//"densities.xml",array2d=qt%densities,array1d=qt%qauxvec)

print*,"Performing energy scan..."
open(unit=111,file=output_folder//"T.dat")
QSYS_DEBUG_LEVEL = 0 ! show me less
do Ef = -3.0 , 3.025 , 0.051
    ! Update hamiltonian elemenents value
    call qt%qsystem%update_lattice(c_matrix=coupling)
    call qt%calculate_modes(Ef)
    call qt%solve(1,Ef)

    print*,"Energy:",Ef,sum(qt%Tn(:))
    write(111,"(100f20.6)"),Ef,sum(qt%Tn(:))
enddo
close(111)

! ----------------------------------------------------------
! X. Clean memory...
! ----------------------------------------------------------

call qt%destroy_system()

print*,"Generating plots..."
print*,"Plotting band structure..."
call system("cd "//output_folder//"; ./plot_bands.py")
print*,"Plotting eigenvectors..."
call system("cd "//output_folder//"; ./plot_eigenvecs.py")
print*,"Plotting Transmission..."
call system("cd "//output_folder//"; ./plot_T.py")
print*,"Use Viewer program to see the structure and created leads."

contains

! ----------------------------------------------------------
! Define coupling between atoms
! ----------------------------------------------------------
logical function coupling(atomA,atomB,coupling_mat)
    use modcommons
    implicit none
    type(qatom) :: atomA,atomB
    complex*16  :: coupling_mat(:,:) ! you must overwrite this variable
    ! local variables
    integer         :: xdiff,ydiff
    doubleprecision :: dydiff,dxdiff,t0
    ! Calculate distance between atoms in units of dx.
    dxdiff = (atomA%atom_pos(1)-atomB%atom_pos(1))/dx
    dydiff = (atomA%atom_pos(2)-atomB%atom_pos(2))/dx
    ! Convert it to integers
    xdiff = NINT(dxdiff)
    ydiff = NINT(dydiff)

    ! default return value
    coupling       = .false.
    coupling_mat   = 0.0
    t0 = -1
    if( xdiff == 0 .and. ydiff == 0 ) then
        coupling      = .true.
        coupling_mat = t0 * MAT_SX
    else if( abs(xdiff) ==  1 .and. ydiff == 0 ) then
        coupling = .true.
        coupling_mat = 0.5*t0 *(MAT_SX + xdiff*II*MAT_SY)
    else if( xdiff ==  0 .and. abs(ydiff) == 1 ) then
        coupling = .true.
        coupling_mat = 0.5*t0 *(MAT_SX + ydiff*II*MAT_SY)
    endif
end function coupling

end program graphen

max_stars_repo_name: kmkolasinski/Bubel

max_issues_repo_name: kmkolasinski/Bubel

max_forks_repo_name: kmkolasinski/Bubel


text:
module sort_box_module
  ! Adapted from Meissner, Adams, et.al., and NR.

  use box_module

  implicit none

  interface box_sort
     module procedure heapsort_box
  end interface box_sort

contains

  subroutine heapsort_box( array, cmp)
    type(box), dimension(:), intent(in out) :: array
    interface
       function cmp(a,b) result(r)
         use box_module
         implicit none
         logical :: r
         type(box), intent(in) :: a, b
       end function cmp
    end interface
    optional cmp

    if ( present(cmp) ) then
       call he_sort_cmp(array,cmp)
    else
       call he_sort_no_cmp(array)
    end if

  contains

    subroutine box_swap(a,b)
      type(box), intent(inout) :: a, b
      type(box) :: t
      t = a; a = b; b = t
    end subroutine box_swap

    subroutine he_sort_cmp(array,cmp)
      type(box), dimension(:), intent(in out) :: array
      interface
         function cmp(a,b) result(r)
           use box_module
           implicit none
           logical :: r
           type(box), intent(in) :: a, b
         end function cmp
      end interface
      integer :: n, i

      n = size (array)
      do i = n / 2, 1, -1
         call peck_cmp(array,i,n,cmp)
      end do
      do i = n, 2, -1
         call box_swap(array(1),array(i))
         call peck_cmp(array,1, i-1,cmp)
      end do

    end subroutine he_sort_cmp

    subroutine he_sort_no_cmp(array)
      type(box), dimension(:), intent(in out) :: array
      integer :: n, i

      n = size (array)
      do i = n / 2, 1, -1
         call peck_no_cmp(array,i,n)
      end do
      do i = n, 2, -1
         call box_swap(array(1),array(i))
         call peck_no_cmp(array,1, i-1)
      end do

    end subroutine he_sort_no_cmp

    subroutine peck_cmp(array,l,r,cmp)
      type(box), dimension(:), intent(inout) :: array
      integer, intent(in) :: r
      integer, intent(in) :: l
      interface
         function cmp(a,b) result(r)
           use box_module
           implicit none
           logical :: r
           type(box), intent(in) :: a, b
         end function cmp
      end interface
      integer :: i
      type(box) :: next

      next = array(l)
      i = 2*l
      do while ( i <= r )
         if ( i < r ) then
            if ( cmp(array(i), array(i+1)) ) i = i+1
         end if
         if ( .not. cmp( next, array(i)) ) exit
         array(i/2) = array(i)
         i = 2*i
      end do
      array(i/2) = next

    end subroutine peck_cmp

    subroutine peck_no_cmp(array,l,r)
      type(box), dimension(:), intent(inout) :: array
      integer, intent(in) :: r
      integer, intent(in) :: l
      integer :: i

      type(box) :: next
      next = array(l)
      i = 2*l
      do while ( i <= r )
         if ( i < r ) then
            if ( box_less(array(i), array(i+1)) ) i = i+1
         end if
         if ( .not. box_less( next, array(i)) ) exit
         array(i/2) = array(i)
         i = 2*i
      end do
      array(i/2) = next

    end subroutine peck_no_cmp

  end subroutine heapsort_box

end module sort_box_module

max_stars_repo_name: huahbo/miniSMC

max_issues_repo_name: kiranhegde/miniSMC

max_forks_repo_name: kiranhegde/miniSMC


text:
! :::::::::: bc1amr ::::::::::::::::::::::::::::::::::::::::::::::;
!
!     Take a grid patch with mesh width hx of dimensions nrow
!     and set the values of any piece of
!     of the patch which extends outside the physical domain
!     using the boundary conditions.
!
!     ------------------------------------------------
!     # Standard boundary condition choices for amr in clawpack
!
!     # At each boundary  k = 1 (left),  2 (right):
!     #   mthbc(k) =  0  for user-supplied BC's (must be inserted!)
!     #            =  1  for zero-order extrapolation
!     #            =  2  for periodic boundary conditions
!     #            =  3  for solid walls, assuming this can be implemented
!     #                  by reflecting the data about the boundary and then
!     #                  negating the 2'nd (for k=1,2) component of q.
!     #            =  5  sphere bcs (left half maps to right half of same
!     #                  side, and vice versa), as if domain folded in half
!     ------------------------------------------------
!
!     The edges of the grid patch are at
!        xlo_patch  -- left edge
!        xhi_patch --  right edge
!
!     The physical domain itself is a rectangle bounded by
!        xlower  -- left edge
!        xupper  -- right edge
!
!     the picture is the following:
!            (xlower)                    (xupper)
!        |______|_________|_________________|
!        |      |         |                 |
!   (xlo_patch)       (xhi_patch)
!
!
!     Any cells that lie outside the physical domain are ghost cells whose
!     values should be set in this routine.  This is tested for by comparing
!     xlo_patch with xlower to see if values need to be set at the left, as in
!     the figure above, and similarly at the other boundary.
!
!     Patches are guaranteed to have at least 1 row of cells filled
!     with interior values so it is possible to  extrapolate.
!     Fix trimbd if you want more than 1 row pre-set.
!
!     Make sure the order the boundaries are specified is correct
!     so that diagonal corner cells are also properly taken care of.
!
!     Periodic boundaries are set before calling this routine, so if the
!     domain is periodic in one direction only you
!     can safely extrapolate in the other direction.
!
!     Don't overwrite ghost cells in periodic directions!
!
! ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::;

subroutine bc1amr(val, aux, nrow, meqn,naux, hx, level, time,           &
                  xlo_patch, xhi_patch)

    use amr_module, only: mthbc, xlower, xupper
    use amr_module, only: xperdom

    implicit none

    ! Input/Output
    integer, intent(in) :: nrow, meqn, naux, level
    real(kind=8), intent(in) :: hx, time
    real(kind=8), intent(in) :: xlo_patch, xhi_patch
    real(kind=8), intent(in out) :: val(meqn, nrow)
    real(kind=8), intent(in out) :: aux(naux, nrow)

    ! Local storage
    integer :: i, ibeg, nxl, nxr
    real(kind=8) :: hxmarg

    hxmarg = hx * .01d0

    ! Use periodic boundary condition specialized code only, if only one
    ! boundary is periodic we still proceed below
    if (xperdom) then
        return
    end if

    ! Each check has an initial check to ensure that the boundary is a real
    ! boundary condition and otherwise skips the code.  Otherwise
    !-------------------------------------------------------
    ! Left boundary:
    !-------------------------------------------------------
    if (xlo_patch < xlower-hxmarg) then
        ! number of grid cells from this patch lying outside physical domain:
        nxl = int((xlower + hxmarg - xlo_patch) / hx)

        select case(mthbc(1))
            case(0) ! User defined boundary condition
                ! Replace this code with a user defined boundary condition
                stop "A user defined boundary condition was not provided."
            case(1) ! Zero-order extrapolation
                do i=1, nxl
                    val(:, i) = val(:, nxl + 1)
                end do

            case(2) ! Periodic boundary condition
                continue

            case(3) ! Wall boundary conditions
                do i=1, nxl
                    aux(:, i) = aux(:, 2 * nxl + 1 - i)
                    val(:, i) = val(:, 2 * nxl + 1 - i)
                end do
                ! negate the normal velocity:
                do i=1, nxl
                    val(2, i) = -val(2, i)
                end do

            case default
                print *, "Invalid boundary condition requested."
                stop
        end select
    end if

    !-------------------------------------------------------
    ! Right boundary:
    !-------------------------------------------------------
    if (xhi_patch > xupper+hxmarg) then

        ! number of grid cells lying outside physical domain:
        nxr = int((xhi_patch - xupper + hxmarg) / hx)
        ibeg = max(nrow - nxr + 1, 1)

        select case(mthbc(2))
            case(0) ! User defined boundary condition
                ! Replace this code with a user defined boundary condition
                stop "A user defined boundary condition was not provided."
            case(1) ! Zero-order extrapolation
                do i = ibeg, nrow
                    val(:, i) = val(:, ibeg - 1)
                end do

            case(2) ! Periodic boundary condition
                continue

            case(3) ! Wall boundary conditions
                do i=ibeg, nrow
                    val(:, i) = val(:, 2 * ibeg - 1 - i)
                end do
                ! negate the normal velocity:
                do i = ibeg, nrow
                    val(2, i) = -val(2, i)
                end do

            case default
                print *, "Invalid boundary condition requested."
                stop

        end select
    end if

end subroutine bc1amr

max_stars_repo_name: navravi/amrclaw

max_issues_repo_name: navravi/amrclaw

max_forks_repo_name: navravi/amrclaw


text:
c*************************************************************************
c                            RMVS3_ELOG.F
c*************************************************************************
c This subroutine keeps a log of the close encounters using istat
c
c             Input:
c                 ntp           ==>  number of massive bodies (int scalar)
c                 icflg         ==> ecounters? = 1 Yes, in inner region only
c                                              =  0 No (integer scalar)
c                 ienc          ==> ienc(j) = 0 if tp j not involved in enc
c                                   in inner region: = planet# if it is.
c                                     (integer array)
c                 istat           ==>  status of the test paricles
c                                      (2d integer array)
c                                      istat(i,1) = 0 ==> active:  = 1 not
c                                      istat(i,NSTATP+n-1) is number of
c                                          inner encounters that tp i had
c                                          with planet n
c             Output:
c                 istat           ==>  status of the test paricles
c                                      (2d integer array)
c                                      istat(i,1) = 0 ==> active:  = 1 not
c                                      istat(i,NSTATP+n-1) is number of
c                                          inner encounters that tp i had
c                                          with planet n (updated).
c
c
c Remarks: BAsed on rmvs_elog
c Authors:  Hal Levison
c Date:    7/10/96
c Last revision:

      subroutine rmvs3_elog(ntp,icflg,ienc,istat)

      include '../swift.inc'
      include '../rmvs/rmvs.inc'

c...  Inputs Only:
      integer ntp,icflg,ienc(NTPMAX)

c...  Inputs and Outputs:
      integer istat(NTPMAX,NSTAT)

c...  Internals
      integer i,i1st,iencio(NTPMAX),np

      data i1st/0/

      save i1st,iencio

c----
c...  Executable code

c...  set up the old storage location
      if(i1st.eq.0) then
         do i=1,ntp
            iencio(i) = 0
         enddo
         i1st = 1
      endif

c...  check for new encounters
      if(icflg.eq.1) then
         do i=1,ntp
            if( (iencio(i).eq.0) .and. (ienc(i).ne.0) ) then
               np = NSTATP + ienc(i) - 1
               istat(i,np) = istat(i,np) + 1
            endif
         enddo
      endif

c.... save the current values
      do i=1,ntp
         iencio(i) = ienc(i)
      enddo

      return
      end                       ! rmvs3_elog
c------------------------------------------------------

max_stars_repo_name: Simske/exostriker


text:
! This file was automatically generated by SWIG (http://www.swig.org).
! Version 4.0.0
!
! Do not make changes to this file unless you know what you are doing--modify
! the SWIG interface file instead.
module fsundials_matrix_mod
 use, intrinsic :: ISO_C_BINDING
 use fsundials_types_mod
 use fsundials_nvector_mod
 use fsundials_types_mod
 implicit none
 private

 ! DECLARATION CONSTRUCTS
 ! typedef enum SUNMatrix_ID
 enum, bind(c)
  enumerator :: SUNMATRIX_DENSE
  enumerator :: SUNMATRIX_BAND
  enumerator :: SUNMATRIX_SPARSE
  enumerator :: SUNMATRIX_SLUNRLOC
  enumerator :: SUNMATRIX_CUSPARSE
  enumerator :: SUNMATRIX_CUSTOM
 end enum
 integer, parameter, public :: SUNMatrix_ID = kind(SUNMATRIX_DENSE)
 public :: SUNMATRIX_DENSE, SUNMATRIX_BAND, SUNMATRIX_SPARSE, SUNMATRIX_SLUNRLOC, SUNMATRIX_CUSPARSE, SUNMATRIX_CUSTOM
 ! struct struct _generic_SUNMatrix_Ops
 type, bind(C), public :: SUNMatrix_Ops
  type(C_FUNPTR), public :: getid
  type(C_FUNPTR), public :: clone
  type(C_FUNPTR), public :: destroy
  type(C_FUNPTR), public :: zero
  type(C_FUNPTR), public :: copy
  type(C_FUNPTR), public :: scaleadd
  type(C_FUNPTR), public :: scaleaddi
  type(C_FUNPTR), public :: matvecsetup
  type(C_FUNPTR), public :: matvec
  type(C_FUNPTR), public :: space
 end type SUNMatrix_Ops
 ! struct struct _generic_SUNMatrix
 type, bind(C), public :: SUNMatrix
  type(C_PTR), public :: content
  type(C_PTR), public :: ops
 end type SUNMatrix
 public :: FSUNMatNewEmpty
 public :: FSUNMatFreeEmpty
 public :: FSUNMatCopyOps
 public :: FSUNMatGetID
 public :: FSUNMatClone
 public :: FSUNMatDestroy
 public :: FSUNMatZero
 public :: FSUNMatCopy
 public :: FSUNMatScaleAdd
 public :: FSUNMatScaleAddI
 public :: FSUNMatMatvecSetup
 public :: FSUNMatMatvec
 public :: FSUNMatSpace
 integer(C_INT), parameter, public :: SUNMAT_SUCCESS = 0_C_INT
 integer(C_INT), parameter, public :: SUNMAT_ILL_INPUT = -701_C_INT
 integer(C_INT), parameter, public :: SUNMAT_MEM_FAIL = -702_C_INT
 integer(C_INT), parameter, public :: SUNMAT_OPERATION_FAIL = -703_C_INT
 integer(C_INT), parameter, public :: SUNMAT_MATVEC_SETUP_REQUIRED = -704_C_INT

! WRAPPER DECLARATIONS
interface
function swigc_FSUNMatNewEmpty() &
bind(C, name="_wrap_FSUNMatNewEmpty") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR) :: fresult
end function

subroutine swigc_FSUNMatFreeEmpty(farg1) &
bind(C, name="_wrap_FSUNMatFreeEmpty")
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: farg1
end subroutine

function swigc_FSUNMatCopyOps(farg1, farg2) &
bind(C, name="_wrap_FSUNMatCopyOps") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: farg1
type(C_PTR), value :: farg2
integer(C_INT) :: fresult
end function

function swigc_FSUNMatGetID(farg1) &
bind(C, name="_wrap_FSUNMatGetID") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: farg1
integer(C_INT) :: fresult
end function

function swigc_FSUNMatClone(farg1) &
bind(C, name="_wrap_FSUNMatClone") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: farg1
type(C_PTR) :: fresult
end function

subroutine swigc_FSUNMatDestroy(farg1) &
bind(C, name="_wrap_FSUNMatDestroy")
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: farg1
end subroutine

function swigc_FSUNMatZero(farg1) &
bind(C, name="_wrap_FSUNMatZero") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: farg1
integer(C_INT) :: fresult
end function

function swigc_FSUNMatCopy(farg1, farg2) &
bind(C, name="_wrap_FSUNMatCopy") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: farg1
type(C_PTR), value :: farg2
integer(C_INT) :: fresult
end function

function swigc_FSUNMatScaleAdd(farg1, farg2, farg3) &
bind(C, name="_wrap_FSUNMatScaleAdd") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
real(C_DOUBLE), intent(in) :: farg1
type(C_PTR), value :: farg2
type(C_PTR), value :: farg3
integer(C_INT) :: fresult
end function

function swigc_FSUNMatScaleAddI(farg1, farg2) &
bind(C, name="_wrap_FSUNMatScaleAddI") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
real(C_DOUBLE), intent(in) :: farg1
type(C_PTR), value :: farg2
integer(C_INT) :: fresult
end function

function swigc_FSUNMatMatvecSetup(farg1) &
bind(C, name="_wrap_FSUNMatMatvecSetup") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: farg1
integer(C_INT) :: fresult
end function

function swigc_FSUNMatMatvec(farg1, farg2, farg3) &
bind(C, name="_wrap_FSUNMatMatvec") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: farg1
type(C_PTR), value :: farg2
type(C_PTR), value :: farg3
integer(C_INT) :: fresult
end function

function swigc_FSUNMatSpace(farg1, farg2, farg3) &
bind(C, name="_wrap_FSUNMatSpace") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: farg1
type(C_PTR), value :: farg2
type(C_PTR), value :: farg3
integer(C_INT) :: fresult
end function

end interface

contains
 ! MODULE SUBPROGRAMS
function FSUNMatNewEmpty() &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
type(SUNMatrix), pointer :: swig_result
type(C_PTR) :: fresult

fresult = swigc_FSUNMatNewEmpty()
call c_f_pointer(fresult, swig_result)
end function

subroutine FSUNMatFreeEmpty(a)
use, intrinsic :: ISO_C_BINDING
type(SUNMatrix), target, intent(inout) :: a
type(C_PTR) :: farg1

farg1 = c_loc(a)
call swigc_FSUNMatFreeEmpty(farg1)
end subroutine

function FSUNMatCopyOps(a, b) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
integer(C_INT) :: swig_result
type(SUNMatrix), target, intent(inout) :: a
type(SUNMatrix), target, intent(inout) :: b
integer(C_INT) :: fresult
type(C_PTR) :: farg1
type(C_PTR) :: farg2

farg1 = c_loc(a)
farg2 = c_loc(b)
fresult = swigc_FSUNMatCopyOps(farg1, farg2)
swig_result = fresult
end function

function FSUNMatGetID(a) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
integer(SUNMatrix_ID) :: swig_result
type(SUNMatrix), target, intent(inout) :: a
integer(C_INT) :: fresult
type(C_PTR) :: farg1

farg1 = c_loc(a)
fresult = swigc_FSUNMatGetID(farg1)
swig_result = fresult
end function

function FSUNMatClone(a) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
type(SUNMatrix), pointer :: swig_result
type(SUNMatrix), target, intent(inout) :: a
type(C_PTR) :: fresult
type(C_PTR) :: farg1

farg1 = c_loc(a)
fresult = swigc_FSUNMatClone(farg1)
call c_f_pointer(fresult, swig_result)
end function

subroutine FSUNMatDestroy(a)
use, intrinsic :: ISO_C_BINDING
type(SUNMatrix), target, intent(inout) :: a
type(C_PTR) :: farg1

farg1 = c_loc(a)
call swigc_FSUNMatDestroy(farg1)
end subroutine

function FSUNMatZero(a) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
integer(C_INT) :: swig_result
type(SUNMatrix), target, intent(inout) :: a
integer(C_INT) :: fresult
type(C_PTR) :: farg1

farg1 = c_loc(a)
fresult = swigc_FSUNMatZero(farg1)
swig_result = fresult
end function

function FSUNMatCopy(a, b) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
integer(C_INT) :: swig_result
type(SUNMatrix), target, intent(inout) :: a
type(SUNMatrix), target, intent(inout) :: b
integer(C_INT) :: fresult
type(C_PTR) :: farg1
type(C_PTR) :: farg2

farg1 = c_loc(a)
farg2 = c_loc(b)
fresult = swigc_FSUNMatCopy(farg1, farg2)
swig_result = fresult
end function

function FSUNMatScaleAdd(c, a, b) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
integer(C_INT) :: swig_result
real(C_DOUBLE), intent(in) :: c
type(SUNMatrix), target, intent(inout) :: a
type(SUNMatrix), target, intent(inout) :: b
integer(C_INT) :: fresult
real(C_DOUBLE) :: farg1
type(C_PTR) :: farg2
type(C_PTR) :: farg3

farg1 = c
farg2 = c_loc(a)
farg3 = c_loc(b)
fresult = swigc_FSUNMatScaleAdd(farg1, farg2, farg3)
swig_result = fresult
end function

function FSUNMatScaleAddI(c, a) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
integer(C_INT) :: swig_result
real(C_DOUBLE), intent(in) :: c
type(SUNMatrix), target, intent(inout) :: a
integer(C_INT) :: fresult
real(C_DOUBLE) :: farg1
type(C_PTR) :: farg2

farg1 = c
farg2 = c_loc(a)
fresult = swigc_FSUNMatScaleAddI(farg1, farg2)
swig_result = fresult
end function

function FSUNMatMatvecSetup(a) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
integer(C_INT) :: swig_result
type(SUNMatrix), target, intent(inout) :: a
integer(C_INT) :: fresult
type(C_PTR) :: farg1

farg1 = c_loc(a)
fresult = swigc_FSUNMatMatvecSetup(farg1)
swig_result = fresult
end function

function FSUNMatMatvec(a, x, y) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
integer(C_INT) :: swig_result
type(SUNMatrix), target, intent(inout) :: a
type(N_Vector), target, intent(inout) :: x
type(N_Vector), target, intent(inout) :: y
integer(C_INT) :: fresult
type(C_PTR) :: farg1
type(C_PTR) :: farg2
type(C_PTR) :: farg3

farg1 = c_loc(a)
farg2 = c_loc(x)
farg3 = c_loc(y)
fresult = swigc_FSUNMatMatvec(farg1, farg2, farg3)
swig_result = fresult
end function

function FSUNMatSpace(a, lenrw, leniw) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
integer(C_INT) :: swig_result
type(SUNMatrix), target, intent(inout) :: a
integer(C_LONG), dimension(*), target, intent(inout) :: lenrw
integer(C_LONG), dimension(*), target, intent(inout) :: leniw
integer(C_INT) :: fresult
type(C_PTR) :: farg1
type(C_PTR) :: farg2
type(C_PTR) :: farg3

farg1 = c_loc(a)
farg2 = c_loc(lenrw(1))
farg3 = c_loc(leniw(1))
fresult = swigc_FSUNMatSpace(farg1, farg2, farg3)
swig_result = fresult
end function

end module

max_stars_repo_name: bayesmix-dev/math

max_issues_repo_name: bayesmix-dev/math

max_forks_repo_name: bayesmix-dev/math


text:
module mempool

  use iso_c_binding, only: c_int, c_ptr
  interface
     subroutine cedar_mempool_pos(mp, nbytes, pos) &
          bind(C, name="cedar_mempool_pos")
       use iso_c_binding, only: c_int, c_ptr
       integer(c_int), value :: nbytes
       type(c_ptr) :: mp
       integer(c_int) :: pos
     end subroutine cedar_mempool_pos
  end interface

end module mempool

max_stars_repo_name: cedar-framework/cedar

max_issues_repo_name: cedar-framework/cedar

max_forks_repo_name: cedar-framework/cedar


text:
      subroutine gridloop2(a, xcoor, ycoor, nx, ny, func1)
Cf2py intent(c) gridloop2
      integer nx, ny
Cf2py intent(c) nx,ny
      real*8 a(0:nx-1,0:ny-1), xcoor(0:nx-1), ycoor(0:ny-1), func1
      external func1
Cf2py intent(c, out) a
Cf2py intent(in) xcoor, ycoor
Cf2py depend(nx,ny) a

C sample call of callback function:
      real*8 x, y, r
      real*8 func1
Cf2py intent(c) x, y, r, func1
      r = func1(x, y)
      end

max_stars_repo_name: sniemi/SamPy

max_issues_repo_name: sniemi/SamPy

max_forks_repo_name: sniemi/SamPy


text:
c=======================================================================
c
c     function init_random_seed
c
c     Initialize a pseudo-random number sequence
c
c-----------------------------------------------------------------------
c
c     Copyright (c) 2012 NumX
c     515, route de Savoie, 38114 Allemont, France
c     All rights reserved.
c
c     This software is the confidential and proprietary information
c     of NumX. You shall not disclose such Confidential
c     Information and shall use it only in accordance with the terms
c     of the licence agreement you entered into with NumX.
c
c     Author : Yann Vernaz
c
c-----------------------------------------------------------------------
      SUBROUTINE init_random_seed()
c-----------------------------------------------------------------------
c
      REAL, DIMENSION(100) :: rnd
      INTEGER              :: isize,idate(8)
      INTEGER,ALLOCATABLE  :: iseed(:)

      CALL DATE_AND_TIME(VALUES=idate)
      CALL RANDOM_SEED(SIZE=isize)
      ALLOCATE( iseed(isize) )
      CALL RANDOM_SEED(GET=iseed)
      iseed = iseed * (idate(8)-500)  ! idate(8) contains millisecond
      CALL RANDOM_SEED(PUT=iseed)

c      CALL RANDOM_NUMBER(RND)

      DEALLOCATE( iseed )
c
      END SUBROUTINE

max_stars_repo_name: alpgodev/numx

max_issues_repo_name: alpgodev/numx

max_forks_repo_name: alpgodev/numx


! RUN: %S/test_errors.sh %s %t %flang_fc1
! Test alternat return argument passing for internal and external subprograms
! Both of the following are OK
  call extSubprogram (*100)
  call intSubprogram (*100)
  call extSubprogram (*101)
  call intSubprogram (*101)
100 PRINT *,'First alternate return'
!ERROR: Label '101' is not a branch target
!ERROR: Label '101' is not a branch target
101 FORMAT("abc")
contains
  subroutine intSubprogram(*)
    return(1)
  end subroutine
end


text:
      INTEGER FUNCTION fortranread (IUNIT, string, lenString, ISTAT)
C
C     Interface routine for C/C++ functions to write to a file
C     under FORTRAN
!      use ifcore
C
      INTEGER IUNIT, lenString
      CHARACTER string*(*)
C
      INTEGER ISTAT
C
      READ (IUNIT, 20, IOSTAT=ISTAT) STRING
 20   FORMAT(A)
      fortranread = ISTAT
      if (istat.eq.0) then
        call chrlnb(string, lenString)
      endif
C
      RETURN
      END

max_stars_repo_name: HydrologicEngineeringCenter/heclib

max_issues_repo_name: HydrologicEngineeringCenter/heclib

max_forks_repo_name: HydrologicEngineeringCenter/heclib


text:
! MIT License
!
! Copyright (c) 2010-present David A. Kopriva and other contributors: AUTHORS.md
!
! 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.
!
! FTObjectLibrary contains code that, to the best of our knowledge, has been released as
! public domain software:
! * `b3hs_hash_key_jenkins`: originally by Rich Townsend,
! https://groups.google.com/forum/#!topic/comp.lang.fortran/RWoHZFt39ng, 2005
!
! --- End License

!
!////////////////////////////////////////////////////////////////////////
!
!      FTLinkedListClass.f90
!      Created: January 7, 2013 2:56 PM
!      By: David Kopriva
!
!
!
!////////////////////////////////////////////////////////////////////////
!
!@mark -
!
!>FTLinkedListRecord is the record type (object and next) for the
!>LinkedList class.
!>
!>One will generally not instantiate a record oneself. They are
!>created automatically when one adds an object to a linked list.
!>
      Module FTLinkedListRecordClass
      USE FTObjectClass
      IMPLICIT NONE
!
!     -----------------------------
!     Record class for linked lists
!     -----------------------------
!
      TYPE, EXTENDS(FTObject) :: FTLinkedListRecord

         CLASS(FTObject)          , POINTER :: recordObject => NULL()
         CLASS(FTLinkedListRecord), POINTER :: next => NULL(), previous => NULL()
!
!        ========
         CONTAINS
!        ========
!
         PROCEDURE :: initWithObject
         FINAL     :: destructFTLinkedListRecord
         PROCEDURE :: printDescription => printFTLinkedRecordDescription
         PROCEDURE :: className        => llRecordClassName

      END TYPE FTLinkedListRecord
!
!     ----------
!     Procedures
!     ----------
!
      CONTAINS
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE initWithObject(self,obj)
         IMPLICIT NONE
         CLASS(FTLinkedListRecord) :: self
         CLASS(FTObject), POINTER  :: obj
!
!        -------------------------------
!        Always call the superclass init
!        -------------------------------
!
         CALL self % FTObject % init()
!
!        ------------------------
!        Subclass initializations
!        ------------------------
!
         CALL obj % retain()

         self % recordObject => obj
         self % next         => NULL()
         self % previous     => NULL()

      END SUBROUTINE initWithObject
!
!////////////////////////////////////////////////////////////////////////
!
!< The destructor must only be called from within subclass destructors
!
      SUBROUTINE destructFTLinkedListRecord(self)
         IMPLICIT NONE
         TYPE(FTLinkedListRecord) :: self

         IF ( ASSOCIATED(self % recordObject) ) CALL releaseFTObject(self % recordObject)
         self % next     => NULL()
         self % previous => NULL()

      END SUBROUTINE destructFTLinkedListRecord
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE releaseFTLinkedListRecord(self)
         IMPLICIT NONE
         TYPE(FTLinkedListRecord), POINTER :: self
         CLASS(FTObject)         , POINTER :: obj

         IF(.NOT. ASSOCIATED(self)) RETURN

         obj => self
         CALL release(obj)
         IF(.NOT.ASSOCIATED(obj)) self => NULL()
      END SUBROUTINE releaseFTLinkedListRecord
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE printFTLinkedRecordDescription(self,iUnit)
         IMPLICIT NONE
         CLASS(FTLinkedListRecord) :: self
         INTEGER                   :: iUnit

         IF ( ASSOCIATED(self % recordObject) )     THEN
            CALL self % recordObject % printDescription(iUnit)
         END IF

      END SUBROUTINE printFTLinkedRecordDescription
!
!////////////////////////////////////////////////////////////////////////
!
!      -----------------------------------------------------------------
!> Class name returns a string with the name of the type of the object
!>
!>  ### Usage:
!>
!>        PRINT *,  obj % className()
!>        if( obj % className = "FTLinkedListRecord")
!>
      FUNCTION llRecordClassName(self)  RESULT(s)
         IMPLICIT NONE
         CLASS(FTLinkedListRecord)                  :: self
         CHARACTER(LEN=CLASS_NAME_CHARACTER_LENGTH) :: s

         s = "FTLinkedListRecord"

      END FUNCTION llRecordClassName

      END MODULE FTLinkedListRecordClass
!@mark -
!
!
!     --------------------------------------------------
!     Implements the basics of a linked list of objects
!     --------------------------------------------------
!
!>
!>FTLinkedList is a container class that stores objects in a linked list.
!>
!>Inherits from FTObjectClass
!>
!>##Definition (Subclass of FTObject):
!>
!>         TYPE(FTLinkedList) :: list
!>
!>#Usage:
!>
!>##Initialization
!>
!>         CLASS(FTLinkedList), POINTER :: list
!>         ALLOCATE(list)
!>         CALL list % init
!>
!>##Adding objects
!>
!>         CLASS(FTLinkedList), POINTER :: list, listToAdd
!>         CLASS(FTObject)    , POINTER :: objectPtr
!>
!>         objectPtr => r                ! r is subclass of FTObject
!>         CALL list % Add(objectPtr)    ! Pointer is retained by list
!>         CALL release(r)               ! If caller relinquishes ownership
!>
!>         CALL list % addObjectsFromList(listToAdd)
!>
!>##Inserting objects
!>
!>         CLASS(FTLinkedList)      , POINTER :: list
!>         CLASS(FTObject)          , POINTER :: objectPtr, obj
!>         CLASS(FTLinkedListRecord), POINTER :: record
!>
!>         objectPtr => r                                        ! r is subclass of FTObject
!>         CALL list % insertObjectAfterRecord(objectPtr,record) ! Pointer is retained by list
!>         CALL release(r)                                       ! If caller reliquishes ownership
!>
!>         objectPtr => r                                     ! r is subclass of FTObject
!>         CALL list % insertObjectAfterObject(objectPtr,obj) ! Pointer is retained by list
!>         CALL release(r)                                    ! If caller reliquishes ownership
!>
!>##Removing objects
!>
!>         CLASS(FTLinkedList), POINTER :: list
!>         CLASS(FTObject)    , POINTER :: objectPtr
!>         objectPtr => r                 ! r is subclass of FTObject
!>         CALL list % remove(objectPtr)
!>
!>##Getting all objects as an object array
!>
!>         CLASS(FTLinkedList)        , POINTER :: list
!>         CLASS(FTMutableObjectArray), POINTER :: array
!>         array => list % allObjects() ! Array has refCount = 1
!>
!>##Counting the number of objects in the list
!>
!>         n = list % count()
!>
!>##Destruction
!>
!>         CALL releaseFTLinkedList(list) [Pointers]
!>!
      Module FTLinkedListClass
!
      USE FTLinkedListRecordClass
      USE FTMutableObjectArrayClass
      IMPLICIT NONE
!
!     -----------------
!     Class object type
!     -----------------
!
      TYPE, EXTENDS(FTObject) :: FTLinkedList

         CLASS(FTLinkedListRecord), POINTER :: head => NULL(), tail => NULL()
         INTEGER                            :: nRecords
         LOGICAL                            :: isCircular_
!
!        ========
         CONTAINS
!        ========
!
         PROCEDURE :: init             => initFTLinkedList
         PROCEDURE :: add
         PROCEDURE :: remove           => removeObject
         PROCEDURE :: reverse          => reverseLinkedList
         PROCEDURE :: removeRecord     => removeLinkedListRecord
         FINAL     :: destructFTLinkedList
         PROCEDURE :: count            => numberOfRecords
         PROCEDURE :: description      => FTLinkedListDescription
         PROCEDURE :: printDescription => printFTLinkedListDescription
         PROCEDURE :: className        => linkedListClassName
         PROCEDURE :: allObjects       => allLinkedListObjects
         PROCEDURE :: removeAllObjects => removeAllLinkedListObjects
         PROCEDURE :: addObjectsFromList
         PROCEDURE :: makeCircular
         PROCEDURE :: isCircular
         PROCEDURE :: insertObjectAfterRecord
         PROCEDURE :: insertObjectAfterObject

      END TYPE FTLinkedList

      INTERFACE cast
         MODULE PROCEDURE castObjectToLinkedList
      END INTERFACE cast
!
!     ----------
!     Procedures
!     ----------
!
      CONTAINS
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE initFTLinkedList(self)
         IMPLICIT NONE
         CLASS(FTLinkedList) :: self
!
!        -------------------------------
!        Always call the superclass init
!        -------------------------------
!
         CALL self % FTObject % init()
!
!        --------------------------------------
!        Then call the subclass initializations
!        --------------------------------------
!
         self % nRecords    = 0
         self % isCircular_ = .FALSE.

         self % head => NULL(); self % tail => NULL()

      END SUBROUTINE initFTLinkedList
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE add(self,obj)
         IMPLICIT NONE
         CLASS(FTLinkedList)                :: self
         CLASS(FTObject)          , POINTER :: obj
         CLASS(FTLinkedListRecord), POINTER :: newRecord => NULL()

         ALLOCATE(newRecord)
         CALL newRecord % initWithObject(obj)

         IF ( .NOT.ASSOCIATED(self % head) )     THEN
            self % head => newRecord
         ELSE
            self % tail % next   => newRecord
            newRecord % previous => self % tail
         END IF

         self % tail => newRecord
         self % nRecords = self % nRecords + 1

      END SUBROUTINE add
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE addObjectsFromList(self,list)
         IMPLICIT NONE
         CLASS(FTLinkedList)                :: self
         CLASS(FTLinkedList)      , POINTER :: list
         CLASS(FTLinkedListRecord), POINTER :: recordPtr => NULL()
         CLASS(FtObject)          , POINTER :: obj       => NULL()
         LOGICAL                            :: circular

         IF(.NOT.ASSOCIATED(list % head)) RETURN

         circular = list % isCircular()
         CALL list % makeCircular(.FALSE.)

         recordPtr => list % head
         DO WHILE(ASSOCIATED( recordPtr ))
            obj => recordPtr % recordObject
            CALL self % add(obj)

            recordPtr => recordPtr % next
         END DO

         CALL list % makeCircular(circular)

      END SUBROUTINE addObjectsFromList
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE insertObjectAfterRecord(self,obj,after)
         IMPLICIT NONE
         CLASS(FTLinkedList)                :: self
         CLASS(FTObject)          , POINTER :: obj
         CLASS(FTLinkedListRecord), POINTER :: newRecord   => NULL()
         CLASS(FTLinkedListRecord), POINTER :: after, next => NULL()

         ALLOCATE(newRecord)
         CALL newRecord % initWithObject(obj)

         next                 => after % next
         newRecord % next     => next
         newRecord % previous => after
         after % next         => newRecord
         next % previous      => newRecord

         IF ( .NOT.ASSOCIATED( newRecord % next ) )     THEN
            self % tail => newRecord
         END IF

         self % nRecords = self % nRecords + 1

      END SUBROUTINE insertObjectAfterRecord
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE insertObjectAfterObject(self,obj,after)
         IMPLICIT NONE
         CLASS(FTLinkedList)                :: self
         CLASS(FTObject)          , POINTER :: obj, after

         CLASS(FTLinkedListRecord), POINTER :: current => NULL(), previous => NULL()

         IF ( .NOT.ASSOCIATED(self % head) )     THEN
            CALL self % add(obj)
            RETURN
         END IF

         current  => self % head
         previous => NULL()
!
!        -------------------------------------------------------------
!        Find the object in the list by a linear search and
!        add the new object after it.
!        It will be deallocated if necessary.
!        -------------------------------------------------------------
!
         DO WHILE (ASSOCIATED(current))

            IF ( ASSOCIATED(current % recordObject,after) )     THEN
               CALL self % insertObjectAfterRecord(obj = obj,after = current)
               RETURN
            END IF

            previous => current
            current  => current % next
         END DO

      END SUBROUTINE insertObjectAfterObject
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE makeCircular(self,circular)
         IMPLICIT NONE
         CLASS(FTLinkedList) :: self
         LOGICAL             :: circular

         IF ( circular )     THEN
            self % head % previous => self % tail
            self % tail % next     => self % head
            self % isCircular_ = .TRUE.
         ELSE
            self % head % previous => NULL()
            self % tail % next     => NULL()
            self % isCircular_ = .FALSE.
         END IF
      END SUBROUTINE makeCircular
!
!////////////////////////////////////////////////////////////////////////
!
      LOGICAL FUNCTION isCircular(self)
         IMPLICIT NONE
         CLASS(FTLinkedList) :: self
         isCircular = self % isCircular_
      END FUNCTION isCircular
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE removeObject1(self,obj)
         IMPLICIT NONE
         CLASS(FTLinkedList)                :: self
         CLASS(FTObject)          , POINTER :: obj

         CLASS(FTLinkedListRecord), POINTER :: current => NULL(), previous => NULL()

         IF ( .NOT.ASSOCIATED(self % head) )     RETURN

         current  => self % head
         previous => NULL()
!
!        -------------------------------------------------------------
!        Find the object in the list by a linear search and remove it.
!        It will be deallocated if necessary.
!        -------------------------------------------------------------
!
         DO WHILE (ASSOCIATED(current))
            IF ( ASSOCIATED(current % recordObject,obj) )     THEN

               IF ( ASSOCIATED(previous) )     THEN
                  previous % next => current % next
               ELSE
                  self % head => current % next
               END IF

               IF ( ASSOCIATED(current,self % tail) )     THEN
                  self % tail => previous
               END IF

               obj => current
               CALL release(obj)

               self % nRecords = self % nRecords - 1
               EXIT
            END IF

            previous => current
            current  => current % next
         END DO

      END SUBROUTINE removeObject1
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE removeObject(self,obj)
         IMPLICIT NONE
         CLASS(FTLinkedList)                :: self
         CLASS(FTObject)          , POINTER :: obj

         CLASS(FTLinkedListRecord), POINTER :: current => NULL(), previous => NULL()

         IF ( .NOT.ASSOCIATED(self % head) )     RETURN

         current  => self % head
         previous => NULL()
!
!        -------------------------------------------------------------
!        Find the object in the list by a linear search and remove it.
!        It will be deallocated if necessary.
!        -------------------------------------------------------------
!
         DO WHILE (ASSOCIATED(current))

            IF ( ASSOCIATED(current % recordObject,obj) )     THEN
               CALL self % removeRecord(current)
               EXIT
            END IF

            previous => current
            current  => current % next
         END DO

      END SUBROUTINE removeObject
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE removeLinkedListRecord(self,listRecord)
         IMPLICIT NONE
!
!        ---------
!        Arguments
!        ---------
!
         CLASS(FTLinkedList)                :: self
         CLASS(FTLinkedListRecord), POINTER :: listRecord
!
!        ---------------
!        Local variables
!        ---------------
!
         CLASS(FTLinkedListRecord), POINTER :: previous => NULL(), next => NULL()
         CLASS(FTObject)          , POINTER :: obj
!
!        ---------------------------------------------------
!        Turn cirularity off and then back on
!        to work around an what appears to be an
!        ifort bug testing the association of two pointers.
!        ---------------------------------------------------
!
         LOGICAL :: circ
         circ = self % isCircular()
         IF(circ) CALL self % makeCircular(.FALSE.)

         previous => listRecord % previous
         next     => listRecord % next

         IF ( .NOT.ASSOCIATED(listRecord % previous) )     THEN
            self % head => next
            IF ( ASSOCIATED(next) )     THEN
               self % head % previous => NULL()
            END IF
         END IF

         IF ( .NOT.ASSOCIATED(listRecord % next) )     THEN
            self % tail => previous
            IF ( ASSOCIATED(previous) )     THEN
               self % tail % next => NULL()
            END IF
         END IF

         IF ( ASSOCIATED(previous) .AND. ASSOCIATED(next) )     THEN
            previous % next => next
            next % previous => previous
         END IF

         obj => listRecord
         CALL release(obj)

         self % nRecords = self % nRecords - 1
         IF(circ) CALL self % makeCircular(.TRUE.)

      END SUBROUTINE removeLinkedListRecord
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE removeAllLinkedListObjects(self)
         IMPLICIT NONE
         CLASS(FTLinkedList)                :: self
         CLASS(FTLinkedListRecord), POINTER :: listRecord => NULL(), tmp => NULL()
         LOGICAL                            :: circular
         CLASS(FTObject)          , POINTER :: obj

         IF(.NOT.ASSOCIATED(self % head)) RETURN

         circular = self % isCircular()
         CALL self % makeCircular(.FALSE.)

         listRecord => self % head
         DO WHILE (ASSOCIATED(listRecord))

            tmp => listRecord % next

            obj => listRecord
            CALL release(obj)

            IF(.NOT. ASSOCIATED(listRecord)) THEN
               self % nRecords = self % nRecords - 1
            END IF
            listRecord => tmp
         END DO

         self % head => NULL(); self % tail => NULL()

      END SUBROUTINE removeAllLinkedListObjects
!
!////////////////////////////////////////////////////////////////////////
!
      INTEGER FUNCTION numberOfRecords(self)
         IMPLICIT NONE
         CLASS(FTLinkedList) :: self
          numberOfRecords = self % nRecords
      END FUNCTION numberOfRecords
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE releaseFTLinkedList(self)
         IMPLICIT NONE
         CLASS (FTLinkedList), POINTER :: self
         CLASS(FTObject)   , POINTER :: obj

         IF(.NOT. ASSOCIATED(self)) RETURN

         obj => self
         CALL release(obj)
         IF(.NOT.ASSOCIATED(obj)) self => NULL()
      END SUBROUTINE releaseFTLinkedList
!
!////////////////////////////////////////////////////////////////////////
!
!< The destructor must only be called from within the destructors of subclasses
!> It is automatically called by release().
!
      SUBROUTINE destructFTLinkedList(self)
         IMPLICIT NONE
         TYPE(FTLinkedList)                :: self

         CALL self % removeAllObjects()

      END SUBROUTINE destructFTLinkedList
!
!////////////////////////////////////////////////////////////////////////
!
      FUNCTION FTLinkedListDescription(self)
         IMPLICIT NONE
         CLASS(FTLinkedList)                         :: self
         CLASS(FTLinkedListRecord), POINTER          :: listRecord => NULL()
         CHARACTER(LEN=DESCRIPTION_CHARACTER_LENGTH) :: FTLinkedListDescription

         FTLinkedListDescription = ""
         IF(.NOT.ASSOCIATED(self % head)) RETURN

         listRecord              => self % head
         FTLinkedListDescription = TRIM(listRecord % recordObject % description())
         listRecord              => listRecord % next

         DO WHILE (ASSOCIATED(listRecord))
            FTLinkedListDescription = TRIM(FTLinkedListDescription) // &
                                       CHAR(13) // &
                                       TRIM(listRecord % recordObject % description())
            listRecord => listRecord % next
         END DO
      END FUNCTION FTLinkedListDescription
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE printFTLinkedListDescription(self,iUnit)
         IMPLICIT NONE
         CLASS(FTLinkedList)                 :: self
         INTEGER                             :: iUnit
         CLASS(FTLinkedListRecord), POINTER  :: listRecord => NULL()
         LOGICAL                             :: circular

         IF(.NOT.ASSOCIATED(self % head)) RETURN

         circular                        = .FALSE.
         IF(self % isCircular_) circular = .TRUE.
         CALL self % makeCircular(.FALSE.)

         listRecord => self % head

         DO WHILE (ASSOCIATED(listRecord))
            CALL listRecord % printDescription(iUnit)
            listRecord => listRecord % next
         END DO

         CALL self % makeCircular (circular)

      END SUBROUTINE printFTLinkedListDescription
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE reverseLinkedList(self)
!
!     ------------------------
!     Reverses the linked list
!     ------------------------
!
         IMPLICIT NONE
!
!        ---------
!        Arguments
!        ---------
!
         CLASS(FTLinkedList) :: self
!
!        ---------------
!        Local variables
!        ---------------
!
         CLASS(FTLinkedListRecord), POINTER :: current => NULL(), tmp => NULL()

         IF(.NOT.ASSOCIATED(self % head)) RETURN

         IF ( self % isCircular_ )     THEN
            self % head % previous => NULL()
            self % tail % next     => NULL()
         END IF

         current  => self % head

         DO WHILE (ASSOCIATED(current))
            tmp                => current % next
            current % next     => current % previous
            current % previous => tmp
            current            => tmp
         END DO

         tmp => self % head
         self % head => self % tail
         self % tail => tmp

         CALL self % makeCircular(self % isCircular_)

      END SUBROUTINE reverseLinkedList
!
!////////////////////////////////////////////////////////////////////////
!
      FUNCTION allLinkedListObjects(self)  RESULT(array)
         IMPLICIT NONE
!
!        ---------
!        Arguments
!        ---------
!
         CLASS (FTLinkedList)                 :: self
         CLASS(FTMutableObjectArray), POINTER :: array
!
!        ---------------
!        Local variables
!        ---------------
!
         INTEGER                            :: N
         CLASS(FTLinkedListRecord), POINTER :: listRecord => NULL()
         CLASS(FTObject)          , POINTER :: obj        => NULL()
         LOGICAL                            :: circular

         array => NULL()
         IF(.NOT.ASSOCIATED(self % head)) RETURN

         IF(self % isCircular_) circular = .TRUE.
         CALL self % makeCircular(.FALSE.)

         array => NULL()
         N = self % count()
         IF(N==0)     RETURN

         ALLOCATE(array)
         CALL array % initWithSize(arraySize  = N)

         listRecord => self % head

         DO WHILE (ASSOCIATED(listRecord))
            obj => listRecord % recordObject
            CALL array % addObject(obj)
            listRecord => listRecord % next
         END DO

         CALL self % makeCircular(circular)

      END FUNCTION allLinkedListObjects
!
!////////////////////////////////////////////////////////////////////////
!
!      -----------------------------------------------------------------
!> Class name returns a string with the name of the type of the object
!>
!>  ### Usage:
!>
!>        PRINT *,  obj % className()
!>        if( obj % className = "FTLinkedList")
!>
      FUNCTION linkedListClassName(self)  RESULT(s)
         IMPLICIT NONE
         CLASS(FTLinkedList)                        :: self
         CHARACTER(LEN=CLASS_NAME_CHARACTER_LENGTH) :: s

         s = "FTLinkedList"

      END FUNCTION linkedListClassName
!@mark -
! type conversions
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE castObjectToLinkedList(obj,cast)
!
!     -----------------------------------------------------
!     Cast the base class FTObject to the LinkedList class
!     -----------------------------------------------------
!
         IMPLICIT NONE
         CLASS(FTObject)    , POINTER :: obj
         CLASS(FTLinkedList), POINTER :: cast

         cast => NULL()
         SELECT TYPE (e => obj)
            TYPE is (FTLinkedList)
               cast => e
            CLASS DEFAULT

         END SELECT

      END SUBROUTINE castObjectToLinkedList
!
!////////////////////////////////////////////////////////////////////////
!
      FUNCTION linkedListFromObject(obj) RESULT(cast)
!
!     -----------------------------------------------------
!     Cast the base class FTObject to the LinkedList class
!     -----------------------------------------------------
!
         IMPLICIT NONE
         CLASS(FTObject)    , POINTER :: obj
         CLASS(FTLinkedList), POINTER :: cast

         cast => NULL()
         SELECT TYPE (e => obj)
            TYPE is (FTLinkedList)
               cast => e
            CLASS DEFAULT

         END SELECT

      END FUNCTION linkedListFromObject
!
      END MODULE FTLinkedListClass
!
!@mark -
!
!////////////////////////////////////////////////////////////////////////
!
!>An object for stepping through a linked list.
!>
!>###Definition (Subclass of FTObject):
!>   TYPE(FTLinkedListIterator) :: list
!>
!>
!>###Initialization
!>
!>         CLASS(FTLinkedList)        , POINTER :: list
!>         CLASS(FTLinkedListIterator), POINTER :: iterator
!>         ALLOCATE(iterator)
!>         CALL iterator % initWithFTLinkedList(list)
!>
!>###Accessors
!>
!>         ptr => iterator % list()
!>         ptr => iterator % object()
!>         ptr => iterator % currentRecord()
!>
!>###Iterating
!>
!>         CLASS(FTObject), POINTER :: objectPtr
!>         CALL iterator % setToStart
!>         DO WHILE (.NOT.iterator % isAtEnd())
!>            objectPtr => iterator % object()        ! if the object is wanted
!>            recordPtr => iterator % currentRecord() ! if the record is wanted
!>
!>             Do something with object or record
!>
!>            CALL iterator % moveToNext() ! DON'T FORGET THIS!!
!>         END DO
!>
!>###Destruction
!>
!>         CALL releaseFTLinkedListIterator(iterator) [Pointers]
!
!////////////////////////////////////////////////////////////////////////
!
      Module FTLinkedListIteratorClass
      USE FTLinkedListClass
      IMPLICIT NONE
!
!     -----------------
!     Class object type
!     -----------------
!
      TYPE, EXTENDS(FTObject) :: FTLinkedListIterator
         CLASS(FTLinkedList)      , POINTER :: list    => NULL()
         CLASS(FTLinkedListRecord), POINTER :: current => NULL()
!
!        ========
         CONTAINS
!        ========
!
         PROCEDURE :: init           => initEmpty
         PROCEDURE :: initWithFTLinkedList
         FINAL     :: destructIterator
         PROCEDURE :: isAtEnd        => FTLinkedListIsAtEnd
         PROCEDURE :: object         => FTLinkedListObject
         PROCEDURE :: currentRecord  => FTLinkedListCurrentRecord
         PROCEDURE :: linkedList     => returnLinkedList
         PROCEDURE :: className      => linkedListIteratorClassName
         PROCEDURE :: setLinkedList
         PROCEDURE :: setToStart
         PROCEDURE :: moveToNext
         PROCEDURE :: removeCurrentRecord
      END TYPE FTLinkedListIterator
!
!     ----------
!     Procedures
!     ----------
!
      CONTAINS
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE initEmpty(self)
         IMPLICIT NONE
         CLASS(FTLinkedListIterator)  :: self
!
!        --------------------------------------------
!        Always call the superclass initializer first
!        --------------------------------------------
!
         CALL self % FTObject % init()
!
!        ----------------------------------------------
!        Then call the initializations for the subclass
!        ----------------------------------------------
!
         self % list    => NULL()
         self % current => NULL()

      END SUBROUTINE initEmpty
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE initWithFTLinkedList(self,list)
         IMPLICIT NONE
         CLASS(FTLinkedListIterator)  :: self
         CLASS(FTLinkedList), POINTER :: list
!
!        --------------------------------------------
!        Always call the superclass initializer first
!        --------------------------------------------
!
         CALL self % FTObject % init()
!
!        ----------------------------------------------
!        Then call the initializations for the subclass
!        ----------------------------------------------
!
         self % list    => NULL()
         self % current => NULL()
         CALL self % setLinkedList(list)
         CALL self % setToStart()

      END SUBROUTINE initWithFTLinkedList
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE releaseFTLinkedListIterator(self)
         IMPLICIT NONE
         TYPE(FTLinkedListIterator), POINTER :: self
         CLASS(FTObject)   , POINTER :: obj

         IF(.NOT. ASSOCIATED(self)) RETURN

         obj => self
         CALL release(obj)
         IF(.NOT.ASSOCIATED(obj)) self => NULL()
      END SUBROUTINE releaseFTLinkedListIterator
!
!////////////////////////////////////////////////////////////////////////
!
!< The destuctor must not be called except at the end of destructors of
! subclasses.
!
      SUBROUTINE destructIterator(self)
          IMPLICIT NONE
          TYPE(FTLinkedListIterator) :: self

          CALL releaseMemberList(self)
          self % current => NULL()

      END SUBROUTINE destructIterator
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE releaseMemberList(self)
          IMPLICIT NONE
          CLASS(FTLinkedListIterator) :: self
          CLASS(FTObject), POINTER    :: obj

          IF ( ASSOCIATED(self % list) )     THEN
             obj => self % list
             CALL releaseFTObject(self = obj)
             IF(.NOT. ASSOCIATED(obj)) self % list => NULL()
          END IF
      END SUBROUTINE releaseMemberList
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE setToStart(self)
         IMPLICIT NONE
         CLASS(FTLinkedListIterator)  :: self
         self % current => self % list % head
      END SUBROUTINE setToStart
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE moveToNext(self)
         IMPLICIT NONE
         CLASS(FTLinkedListIterator)  :: self

         IF ( ASSOCIATED(self % current) )     THEN
            self % current => self % current % next
         ELSE
            self % current => NULL()
         END IF

         IF ( ASSOCIATED(self % current, self % list % head) )     THEN
            self % current => NULL()
         END IF

      END SUBROUTINE moveToNext
!
!////////////////////////////////////////////////////////////////////////
!
      LOGICAL FUNCTION FTLinkedListIsAtEnd(self)
         IMPLICIT NONE
         CLASS(FTLinkedListIterator)  :: self
         IF ( ASSOCIATED(self % current) )     THEN
            FTLinkedListIsAtEnd = .false.
         ELSE
            FTLinkedListIsAtEnd = .true.
         END IF
      END FUNCTION FTLinkedListIsAtEnd
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE setLinkedList(self,list)
         IMPLICIT NONE
         CLASS(FTLinkedListIterator)  :: self
         CLASS(FTLinkedList), POINTER :: list
!
!        -----------------------------------
!        Remove current list if there is one
!        -----------------------------------
!
         IF ( ASSOCIATED(list) )     THEN

            IF ( ASSOCIATED(self % list, list) )     THEN
               CALL self % setToStart()
            ELSE IF( ASSOCIATED(self % list) )     THEN
               CALL releaseMemberList(self)
               self % list => list
               CALL self % list % retain()
               CALL self % setToStart
            ELSE
               self % list => list
               CALL self % list % retain()
               CALL self % setToStart()
            END IF

         ELSE

            IF( ASSOCIATED(self % list) )     THEN
               CALL releaseMemberList(self)
            END IF
            self % list => NULL()

         END IF

      END SUBROUTINE setLinkedList
!
!////////////////////////////////////////////////////////////////////////
!
      FUNCTION returnLinkedList(self) RESULT(o)
         IMPLICIT NONE
         CLASS(FTLinkedListIterator)  :: self
         CLASS(FTLinkedList), POINTER     :: o
         o => self % list
      END FUNCTION returnLinkedList
!
!////////////////////////////////////////////////////////////////////////
!
      FUNCTION FTLinkedListObject(self) RESULT(o)
         IMPLICIT NONE
         CLASS(FTLinkedListIterator)  :: self
         CLASS(FTObject), POINTER     :: o
         o => self % current % recordObject
      END FUNCTION FTLinkedListObject
!
!////////////////////////////////////////////////////////////////////////
!
      FUNCTION FTLinkedListCurrentRecord(self) RESULT(o)
         IMPLICIT NONE
         CLASS(FTLinkedListIterator)        :: self
         CLASS(FTLinkedListRecord), POINTER :: o
         o => self % current
      END FUNCTION FTLinkedListCurrentRecord
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE removeCurrentRecord(self)
         IMPLICIT NONE
         CLASS(FTLinkedListIterator)        :: self
         CLASS(FTLinkedListRecord), POINTER :: r, n
         r => self % current
         n => self % current % next

         CALL self % list % removeRecord(r)
         self % current => n

      END SUBROUTINE removeCurrentRecord
!
!////////////////////////////////////////////////////////////////////////
!
!      -----------------------------------------------------------------
!> Class name returns a string with the name of the type of the object
!>
!>  ### Usage:
!>
!>        PRINT *,  obj % className()
!>        if( obj % className = "FTLinkedListIterator")
!>
      FUNCTION linkedListIteratorClassName(self)  RESULT(s)
         IMPLICIT NONE
         CLASS(FTLinkedListIterator)                :: self
         CHARACTER(LEN=CLASS_NAME_CHARACTER_LENGTH) :: s

         s = "FTLinkedListIterator"

      END FUNCTION linkedListIteratorClassName

      END MODULE FTLinkedListIteratorClass

max_stars_repo_name: HigherOrderMethods/FTObjectLibrary

max_issues_repo_name: HigherOrderMethods/FTObjectLibrary

max_forks_repo_name: HigherOrderMethods/FTObjectLibrary


text:
extension/datawidth.cpp
extension/stimgen.cpp
extension/main.cpp