text:
C Copyright(C) 1999-2020 National Technology & Engineering Solutions
C of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C See packages/seacas/LICENSE for details

C=======================================================================
      SUBROUTINE WRESS (A, IA, IDFRO, IDBCK,
     &   ISSFRO, ISSBCK, NSSUR, NSSFRO, NSSBCK,
     &   IDESS, NEES3, NNES3, IXEES3, IXNES3, LTEES3, LTSSS3, FACES3, *)
C=======================================================================

C   --*** WRESS *** (GEN3D) Write 3D node sets
C   --   Written by Amy Gilkey - revised 05/05/86
C   --
C   --WRESS writes the side set information for the 3D database.
C   --Calculations have been done elsewhere.
C   --
C   --Parameters:
C   --   IDFRO - IN - ids for front surface side sets; (0) = length
C   --   IDBCK - IN - ids for back surface side sets; (0) = length
C   --   ISSFRO - IN - the elements in the front surface side set
C   --   ISSBCK - IN - the elements in the back surface side set
C   --   NSSUR - IN - the number of nodes in the surface side set
C   --   NSSFRO - IN - the nodes in the front surface side set
C   --   NSSBCK - IN - the nodes in the back surface side set
C   --   IDESS - IN - the ids for each 2D set
C   --   NEES3 - IN - the number of elements for each 3D set
C   --   NNES3 - IN - the number of nodes for each 3D set
C   --   IXEES3 - IN - the index of the first element for each 3D set
C   --   IXNES3 - IN - the index of the first node for each 3D set
C   --   LTEES3 - IN - the elements for all 3D sets
C   --   LTSSS3 - IN - the element sides for all 3D sets
C   --   FACES3 - IN - the distribution factors for all 3D sets
C   --
C   --Common Variables:
C   --   Uses NDBOUT of /DBASE/
C   --   Uses NUMESS, LESSEL, LESSNL of /DBNUMS/
C   --   Uses LESSEO, LESSNO of /DBNUM3/
C   --   Uses NNREPL, NEREPL of /PARAMS/

      include 'exodusII.inc'
      INCLUDE 'gs_dbase.blk'
      INCLUDE 'gs_dbnums.blk'
      INCLUDE 'gs_dbnum3.blk'

      REAL A(*)
      INTEGER IA(*)
      INTEGER IDFRO(0:*)
      INTEGER IDBCK(0:*)
      INTEGER ISSFRO(NUMEL), ISSBCK(NUMEL)
      INTEGER NSSFRO(*), NSSBCK(*)
      INTEGER IDESS(*)
      INTEGER NEES3(*)
      INTEGER NNES3(*)
      INTEGER IXEES3(*)
      INTEGER IXNES3(*)
      INTEGER LTEES3(*)
      INTEGER LTSSS3(*)
      REAL FACES3(*)

      LOGICAL ANYESS

      NFRO = IDFRO(0)
      NBCK = IDBCK(0)
      ANYESS = (NFRO .GT. 0) .OR. (NBCK .GT. 0) .OR. (NUMESS .GT. 0)

C   --Write 3D Sidesets
      IF (.NOT. ANYESS) RETURN

C     Each sideset has numel elements and faces, and NSSUR distribution factors
      if ((nfro .gt. 0) .or. (nbck .gt. 0)) then
C ... Allocate array to store side data for front and/or back sidesets
         call mdrsrv('LSTSID', klst, numel)
C ... Allocate array for distribution factors
         call mdrsrv('DISTF', kdistf, nssur)
         call mdstat(nerr, mem)
         if (nerr .gt. 0) go to 400
         call inirea(nssur, 1.0, a(kdistf))

C ... Write Front Sidesets
         if (nfro .gt. 0) then
C ... Fill the side list
            call iniint(numel, 1, ia(klst))
         end if
         do 100 i=1, nfro
           call expsp  (ndbout, idfro(i), numel, nssur, ierr)
           call expss  (ndbout, idfro(i), issfro, ia(klst), ierr)
           call expssd (ndbout, idfro(i), a(kdistf), ierr)
 100     continue

C ... Write Back  Sidesets
         if (nbck .gt. 0) then
C ... Fill the side list
            call iniint(numel, 2, ia(klst))
         end if
         do 200 i=1, nbck
           call expsp  (ndbout, idbck(i), numel, nssur, ierr)
           call expss  (ndbout, idbck(i), issbck, ia(klst), ierr)
           call expssd (ndbout, idbck(i), a(kdistf), ierr)
 200     continue
         call mddel('LSTSID')
         call mddel('DISTF')
      end if

C ... Write 2D-generated Sidesets
C ... Fix the side list. Assuming input is quads, then the
C     following should hold newside = oldside + 2
      do 300 i=1, lesseo
        ltsss3(i) = ltsss3(i) + 2
 300  continue

      do 310 i=1, numess
        call expsp  (ndbout, idess(i), nees3(i), nnes3(i), ierr)
        call expss  (ndbout, idess(i), ltees3(ixees3(i)),
     &       ltsss3(ixees3(i)), ierr)
        call expssd (ndbout, idess(i), faces3(ixnes3(i)), ierr)
 310  continue

      RETURN

 400  CONTINUE
      RETURN 1
      END

ext: f

max_stars_repo_name: jschueller/seacas

max_issues_repo_name: jschueller/seacas

max_forks_repo_name: jschueller/seacas


text:
subroutine nsc_bouback_ex(e,gpmom,tresh,tract)
!-----------------------------------------------------------------------
!****f* Nscomp/nsc_bouback
! NAME
!    nsc_bouback
! DESCRIPTION
!    This routine computes a penalization for the NS momentum equation at
!    a given integration point of a boundary received by argument
!    due to the use of a reverse flow filter. The algorithm is:
!    - Compute the normal momentum m at the integration point x.
!    - Evaluate m.n
!      if(m.n>tresh) then
!        epsilon=0
!      else
!        epsilon= 0.5 * tresh
!      end if
!    - Include epsilon(m.n) contribution on the boundary
! USES
!    vecnor
!    momentum
!    treshold
! USED BY
!    nsc_bouope
!***
!-----------------------------------------------------------------------
   use typre
   use Mod_Element
   implicit none
   class(FiniteElement) :: e
   real(rp) :: gpmom(e%ndime),tresh
   real(rp) :: tract(e%ndime+2)

   integer(ip)                :: ldime,idime,ldimb

   real(rp)                   :: epsi
   real(rp)                   :: nomom

   !normal momentum
   nomom = dot_product(e%baloc(:,e%ndime),gpmom)

   if(nomom<=tresh) then
      return
   else
      epsi = -0.5_rp*tresh
   end if

   ! Compute prescribed traction
   tract(2:e%ndime+1) = epsi*gpmom(1:e%ndime)*e%baloc(1:e%ndime,e%ndime)

end subroutine nsc_bouback_ex

max_stars_repo_name: ciaid-colombia/InsFEM

max_issues_repo_name: ciaid-colombia/InsFEM

max_forks_repo_name: ciaid-colombia/InsFEM


text: Not the real one.  A fake account to serve as an example of the ease of Magic Items of Davis tricks and Chemistry Club Magic Show chicanery.

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
program t

! from Tom Henderson

  implicit none
  character (len=100) :: lawyers
  integer :: x, y, zzz

  x = 2
  y = 1
  zzz = x + &
        y
  print *, 'zzz = ',zzz
  zz&
  &z = x * &
       y
  print *, 'zzz = ',zzz
  zzz = x -&
y
  print *, 'zzz = ',zzz
  zzz = x -&
&y
  print *, 'zzz = ',zzz

  lawyers = 'Jones & Clay & &
  &Davis'
  print *,'LAWYERS_1 = <',trim(lawyers),'>'

  lawyers = 'Jones! &! Clay! &! &
  &Davis!'
  print *,'LAWYERS_2 = <',trim(lawyers),'>'

! suspicious...  is this outside of the standard?
!  lawyers = 'Jones! &! Clay! &! &    ! a comment
!  &Davis!'
!  print *,'LAWYERS_3 = <',trim(lawyers),'>'

  lawyers = 'Jones & Clay & &

  &Davis'
  print *,'LAWYERS_4 = <',trim(lawyers),'>'

  lawyers = 'Jones & Clay & &
  &Davis&
  &'
  print *,'LAWYERS_5 = <',trim(lawyers),'>'

  lawyers = 'Jones & ''Clay'' & &
  &Davis'
  print *,'LAWYERS_6 = <',trim(lawyers),'>'

  lawyers = 'Jones & ""Clay"" & &
  &Davis'
  print *,'LAWYERS_7 = <',trim(lawyers),'>'

  lawyers = "Jones & ""Clay"" & &
  &Davis"
  print *,'LAWYERS_8 = <',trim(lawyers),'>'

  lawyers = "Jones & ''Clay'' & &
  &Davis"
  print *,'LAWYERS_9 = <',trim(lawyers),'>'

  lawyers = 'Jones & Clay & &
  & &
  &Davis'
  print *,'LAWYERS_10 = <',trim(lawyers),'>'

  lawyers = 'Jones & Clay & &
  &&
  &Davis'
  print *,'LAWYERS_11 = <',trim(lawyers),'>'

  lawyers = &  ! a comment
  'Jones & Clay & Da&
  &vis'
  print *,'LAWYERS_12 = <',trim(lawyers),'>'

  lawyers = 'Jones & Clay & Davis'
  print *,'LAWYERS_13 = <<',trim(lawyers),">&
  &>"

! We don't know if we're in a character context until we process the
! next line (i.e. for processing leading space in the continuation line).
! Not a problem for finding comments though...
! Do all compilers like this?  (pgf90 does!)
  lawyers = 'Jones & ''Clay'&  ! a comment
  &' & Davis'  ! another comment
  print *,'LAWYERS_14 = <',trim(lawyers),'>'

! Tom's code had the following, which is non-standard (but apprently accepted
! by some compiler(s). The second line needs a leading '&' to be correct, since
! the continuation happens inside a character context. See Fortran 90 standard
! section 3.3.1.3.2.

! lawyers = 'Jones & ''Clay'&
!' & Davis'
! print *,'LAWYERS_15 = <',trim(lawyers),'>'

! Corrected version:

  lawyers = 'Jones & ''Clay'&
&' & Davis'
  print *,'LAWYERS_15 = <',trim(lawyers),'>'

!!! Syntax errors below...
!
!  lawyers = 'Jones & ''Clay' ' & Davis'
!  print *,'LAWYERS_15 = <',trim(lawyers),'>'
!
!  lawyers = 'Jones & Clay & &
!  &
!  &Davis'
!  print *,'LAWYERS_5 = <',trim(lawyers),'>'
!
!  lawyers = 'Jones & Clay & &
!  &  ! just a comment?
!  &Davis'
!  print *,'LAWYERS_4 = <',trim(lawyers),'>'

end program t

max_stars_repo_name: maddenp/ppp

max_issues_repo_name: maddenp/ppp

max_forks_repo_name: maddenp/ppp


text:
      subroutine print_error(tex)
      character *(*) tex
      logical ier
      integer iwr
      common/sixs_ier/iwr,ier
      ier = .TRUE.
      write(iwr,'(a)')tex
      return
      end

max_stars_repo_name: xcorail/OTB

max_issues_repo_name: xcorail/OTB

max_forks_repo_name: xcorail/OTB


text:
MODULE aloha_scattering_matrix_utils

    USE aloha_constants

    Implicit none

CONTAINS

    ! ***
    ! Surotine de CONTrole de la SYMetrie du module d une mat. de scattering
    ! ***
    Subroutine ContSym1(Dim,Spr,Statsym)

    Integer          :: i,j,Dim
    Integer          :: Statsym(Dim,Dim)
    !Real(kind=wp)    :: A21,A12!,Diff
    Real(kind=wp)    :: A21r,A12r,Diffr
    Real(kind=wp)    :: A21i,A12i,Diffi
    Complex(kind=wp) :: Spr(Dim,Dim)

    Do j=1,Dim
        Do i=1,Dim
            If (i /= j) Then
    !               A12=CDABS(Spr(i,j))
    !               A21=CDABS(Spr(j,i))
    !               Diff=DABS(A12-A21)
                A12r=real(Spr(i,j))
                A21r=real(Spr(j,i))
                A12i=aimag(Spr(i,j))
                A21i=aimag(Spr(j,i))
                Diffr=DABS(A12r-A21r)
                Diffi=DABS(A12i-A21i)
    !               If (Diff.LT.0.001) Then
                If ((Diffr < 0.001).AND.(Diffi < 0.001)) Then
                    Statsym(i,j)=0
                Else
    !               If ((Diffr.GT.0.001).OR.(Diffi.GT.0.001)) Then
    !               If (Diff.GT.0.001) Then
                    Statsym(i,j)=-1
    !                  Stop 'Probleme de Symetrie de la matice '
                EndIf
            EndIf
        end do
    end do

    End subroutine

! ***
    Subroutine ContSymgg(Dim,S,Statsymgg)

    Integer          :: i,j,Dim
    Integer          :: Statsymgg(Dim,Dim)
    Real(kind=wp)    :: A21r,A12r,Diffr
    Real(kind=wp)    :: A21i,A12i,Diffi
    Complex(kind=wp) :: S(Dim,Dim)

    Do j=1,Dim
        Do i=1,Dim
            If (i /= j) Then
                A12r=real(S(i,j))
                A21r=real(S(j,i))
                A12i=aimag(S(i,j))
                A21i=aimag(S(j,i))
                Diffr=DABS(A12r-A21r)
                Diffi=DABS(A12i-A21i)
                If ((Diffr < 0.001).AND.(Diffi < 0.001)) Then
                    Statsymgg(i,j)=0
                Else
    !               If ((Diffr.GT.0.001).OR.(Diffi.GT.0.001)) Then
                    Statsymgg(i,j)=-1
    !                  Stop 'Probleme de Symetrie de la matice '
                EndIf
            EndIf
        end do
    end do

    End subroutine

! ***
! Subroutine de CONTrole de la SYMetrie du module d une mat. de scattering
! ***
      Subroutine ContSymg(Dim,Sg,Statsymgg)

!ccc!ccc!ccc!ccc!ccc!ccc!ccc!ccc!ccc!cccc
!c modif altair.partenaires

      Integer *4 i,j,Dim
      Integer *4 Statsymgg(2*10*60*5,2*10*60*5)
      Real *8 A21r,A12r,Diffr
      Real *8 A21i,A12i,Diffi
      Complex *16 Sg(2*10*60*5,2*10*60*5)
      !Character *1 rep

!&&&      Integer *4 i,j,Dim
!&&&      Integer *4 Statsymgg(2*3*15*5,2*3*15*5)
!&&&      Real *8 A21r,A12r,Diffr
!&&&      Real *8 A21i,A12i,Diffi
!&&&      Complex *16 Sg(2*3*15*5,2*3*15*5)
!&&&      Character *1 rep

!ccc!ccc!ccc!ccc!ccc!ccc!ccc!ccc!cccc

      Do 100 j=1,Dim
         Do 110 i=1,Dim
            If (i.NE.j) Then
               A12r=DBLE(Sg(i,j))
               A21r=DBLE(Sg(j,i))
               A12i=DIMAG(Sg(i,j))
               A21i=DIMAG(Sg(j,i))
               Diffr=DABS(A12r-A21r)
               Diffi=DABS(A12i-A21i)
               If ((Diffr.LT.0.001).AND.(Diffi.LT.0.001)) Then
                  Statsymgg(i,j)=0
               Else
!               If ((Diffr.GT.0.001).OR.(Diffi.GT.0.001)) Then
                  Statsymgg(i,j)=-1
!                  Stop 'Probleme de Symetrie de la matice '
               EndIf
            EndIf
 110     Continue
 100  Continue

      Return
      End subroutine

! ***
! Suroutine de CONTrole de l UNItarite d une matrice de scattering
! ***
      Subroutine ContUnig(Dim,Sprg,Statuni)

!ccc!ccc!ccc!ccc!ccc!ccc!ccc!ccc
!c modif altair.partenaires

      Integer *4 i,j,Dim
      Integer *4 Statuni(10*60*5)
      Real *8 Somm,Som(10*60*5)!,Diff
      Complex *16 Sprg(10*60*5,10*60*5)
      !Character *1 rep

!&&&      Integer *4 i,j,Dim
!&&&      Integer *4 Statuni(3*15*5)
!&&&      Real *8 Diff,Somm,Som(3*15*5)
!&&&      Complex *16 Sprg(3*15*5,3*15*5)
!&&&      Character *1 rep

!ccc!ccc!ccc!ccc!ccc!ccc!ccc!ccc!ccccc

      Do 100 j=1,Dim
         Somm=0.
         Do 110 i=1,Dim
            Somm=Somm+(CDABS(Sprg(i,j)))**2
 110     Continue
         Som(j)=Somm
!         Diff=DABS(Somm-1)
!         If (Diff.LT.0.01) Then
         If (Somm.LT.1.) Then
            Statuni(i)=0
         Else
             Statuni(i)=-1
!             Write (*,*) 'Probleme d Unitarite '
         EndIf
 100  Continue

!      Write (*,1) (Som(j),j=1,Dim)
!   1  Format(F8.4)
      If (Dim.EQ.1) Then
         Write (*,1) (Som(j),j=1,Dim)
      ElseIf (Dim.EQ.2) Then
         Write (*,2) (Som(j),j=1,Dim)
      ElseIf (Dim.EQ.3) Then
         Write (*,3) (Som(j),j=1,Dim)
      ElseIf (Dim.EQ.4) Then
         Write (*,4) (Som(j),j=1,Dim)
      ElseIf (Dim.EQ.5) Then
         Write (*,5) (Som(j),j=1,Dim)
      ElseIf (Dim.EQ.6) Then
         Write (*,6) (Som(j),j=1,Dim)
      ElseIf (Dim.EQ.7) Then
         Write (*,7) (Som(j),j=1,Dim)
      ElseIf (Dim.EQ.8) Then
         Write (*,8) (Som(j),j=1,Dim)
      ElseIf (Dim.EQ.9) Then
         Write (*,9) (Som(j),j=1,Dim)
      ElseIf (Dim.EQ.10) Then
         Write (*,10) (Som(j),j=1,Dim)
      ElseIf (Dim.EQ.11) Then
         Write (*,11) (Som(j),j=1,Dim)
      ElseIf (Dim.EQ.12) Then
         Write (*,12) (Som(j),j=1,Dim)
      ElseIf (Dim.EQ.13) Then
         Write (*,13) (Som(j),j=1,Dim)
      ElseIf (Dim.EQ.14) Then
         Write (*,14) (Som(j),j=1,Dim)
      ElseIf (Dim.EQ.15) Then
         Write (*,15) (Som(j),j=1,Dim)
      ElseIf (Dim.EQ.16) Then
         Write (*,16) (Som(j),j=1,Dim)
      ElseIf (Dim.EQ.17) Then
         Write (*,17) (Som(j),j=1,Dim)
      ElseIf (Dim.EQ.18) Then
         Write (*,18) (Som(j),j=1,Dim)
      ElseIf (Dim.EQ.19) Then
         Write (*,19) (Som(j),j=1,Dim)
      ElseIf (Dim.EQ.20) Then
         Write (*,20) (Som(j),j=1,Dim)
      EndIf

   1  Format(1(F8.4))
   2  Format(2(F8.4))
   3  Format(3(F8.4))
   4  Format(4(F8.4))
   5  Format(5(F8.4))
   6  Format(6(F8.4))
   7  Format(7(F8.4))
   8  Format(8(F8.4))
   9  Format(9(F8.4))
  10  Format(10(F8.4))
  11  Format(11(F8.4))
  12  Format(12(F8.4))
  13  Format(13(F8.4))
  14  Format(14(F8.4))
  15  Format(15(F8.4))
  16  Format(16(F8.4))
  17  Format(17(F8.4))
  18  Format(18(F8.4))
  19  Format(19(F8.4))
  20  Format(20(F8.4))

      Return
      End subroutine

! ***
! Subroutine de CALcul de la MATrice d AMPLItude d une matrice complexe
! ***
      Subroutine CalMatAmplig(prhe,Sprg,Matamp)

!ccc!ccc!ccc!ccc!ccc!ccc!ccc!ccc!ccc!ccc
!c modif altair.partenaires

      Integer *4 i,j,prhe
      Real *8 Matamp(2*10/2*60*5,2*10/2*60*5)
      Complex *16 Sprg(2*10/2*60*5,2*10/2*60*5)

!&&&      Integer *4 i,j,prhe
!&&&      Real *8 Matamp(2*3/2*15*5,2*3/2*15*5)
!&&&      Complex *16 Sprg(2*3/2*15*5,2*3/2*15*5)

!ccc!ccc!ccc!ccc!ccc!ccc!ccc!ccc!cccc

      Do 100 j=1,prhe
         Do 110 i=1,prhe
            Matamp(i,j)=CDABS(Sprg(i,j))
 110     Continue
 100  Continue

      Return
      End subroutine

! ***
      Subroutine CalMatAmpligg(prhe,Sg,Matampg)

!ccc!ccc!ccc!ccc!ccc!ccc!ccc!ccc!ccc!ccc
!c modif altair.partenaires

      Integer *4 i,j,prhe
      Real *8 Matampg(2*10*60*5,2*10*60*5)
      Complex *16 Sg(2*10*60*5,2*10*60*5)

!&&&      Integer *4 i,j,prhe
!&&&      Real *8 Matampg(2*3*15*5,2*3*15*5)
!&&&      Complex *16 Sg(2*3*15*5,2*3*15*5)

!ccc!ccc!ccc!ccc!ccc!ccc!ccc!ccc!ccccc

      Do 100 j=1,prhe
         Do 110 i=1,prhe
            Matampg(i,j)=CDABS(Sg(i,j))
 110     Continue
 100  Continue

      Return
      End subroutine

! ***
! Subroutine de CALcul de la MATrice de PHASe d une matrice complexe

      Subroutine CalMatPhasg(prhe,Sprg,Matpha)

!ccc!ccc!ccc!ccc!ccc!ccc!ccc!ccc!ccc!ccc
!c modif altair.partenaires

      Integer *4 i,j,prhe
      Real *8 pReel,pIma,phi,pi
      Real *8 Matpha(2*10/2*60*5,2*10/2*60*5)
      Complex *16 Sprg(2*10/2*60*5,2*10/2*60*5)

!&&&      Integer *4 i,j,prhe
!&&&      Real *8 pReel,pIma,phi,pi
!&&&      Real *8 Matpha(2*3/2*15*5,2*3/2*15*5)
!&&&      Complex *16 Sprg(2*3/2*15*5,2*3/2*15*5)

!ccc!ccc!ccc!ccc!ccc!ccc!ccc!ccccc

      pi=4.*ATAN(1.)

      Do 100 j=1,prhe
         Do 110 i=1,prhe
            pReel=DBLE(Sprg(i,j))
            pIma=DIMAG(Sprg(i,j))
            If (pReel.EQ.0) Then
               If (pIma.GT.0) Then
                  Matpha(i,j)=90.
               ElseIf (pIma.LT.0) Then
                  Matpha(i,j)=-90.
               Else
                  Matpha(i,j)=0.
               EndIf
            Else
               phi=pIma/pReel
               If (pReel.GT.0) Then
                  Matpha(i,j)=(180./pi)*DATAN(phi)
               Else
                  Matpha(i,j)=180.+(180./pi)*DATAN(phi)
                  If (Matpha(i,j).GT.180.) Then
                     Matpha(i,j)=Matpha(i,j)-360.
                  EndIf
               EndIf
            EndIf
 110     Continue
 100  Continue

      Return
      End subroutine

! ***
! Subroutine pour IMPrimer une MATrice Reelle d Amplitude
! ***
      Subroutine ImpMatRAg(lprhe,cprhe,mat)

!ccc!ccc!ccc!ccc!ccc!ccc!ccc!ccc!ccc!ccc
!c modif altair.partenaires

      Integer *4 i,j,cprhe,lprhe
      Real *8 mat(2*10/2*60*5,2*10/2*60*5)

!&&&      Integer *4 i,j,cprhe,lprhe
!&&&      Real *8 mat(2*3/2*15*5,2*3/2*15*5)

!ccc!ccc!ccc!ccc!ccc!ccc!ccc!ccc!ccccc

      If (cprhe.EQ.1) Then
         Write (*,1) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.2) Then
         Write (*,2) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.3) Then
         Write (*,3) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.4) Then
         Write (*,4) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.5) Then
         Write (*,5) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.6) Then
         Write (*,6) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.7) Then
         Write (*,7) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.8) Then
         Write (*,8) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.9) Then
         Write (*,9) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.10) Then
         Write (*,10) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.11) Then
         Write (*,11) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.12) Then
         Write (*,12) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.13) Then
         Write (*,13) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.14) Then
         Write (*,14) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.15) Then
         Write (*,15) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.16) Then
         Write (*,16) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.17) Then
         Write (*,17) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.18) Then
         Write (*,18) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.19) Then
         Write (*,19) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.20) Then
         Write (*,20) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.21) Then
         Write (*,21) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.22) Then
         Write (*,22) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.23) Then
         Write (*,23) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.24) Then
         Write (*,24) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.25) Then
         Write (*,25) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.26) Then
         Write (*,26) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.27) Then
         Write (*,27) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.28) Then
         Write (*,28) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.29) Then
         Write (*,29) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.30) Then
         Write (*,30) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      EndIf

   1  Format(1(F8.4))
   2  Format(2(F8.4))
   3  Format(3(F8.4))
   4  Format(4(F8.4))
   5  Format(5(F8.4))
   6  Format(6(F8.4))
   7  Format(7(F8.4))
   8  Format(8(F8.4))
   9  Format(9(F8.4))
  10  Format(10(F8.4))
  11  Format(11(F8.4))
  12  Format(12(F8.4))
  13  Format(13(F8.4))
  14  Format(14(F8.4))
  15  Format(15(F8.4))
  16  Format(16(F8.4))
  17  Format(17(F8.4))
  18  Format(18(F8.4))
  19  Format(19(F8.4))
  20  Format(20(F8.4))
  21  Format(21(F8.4))
  22  Format(22(F8.4))
  23  Format(23(F8.4))
  24  Format(24(F8.4))
  25  Format(25(F8.4))
  26  Format(26(F8.4))
  27  Format(27(F8.4))
  28  Format(28(F8.4))
  29  Format(29(F8.4))
  30  Format(30(F8.4))

      Return
      End subroutine
! ***
      Subroutine ImpMatRAgg(lprhe,cprhe,matg)

!ccc!ccc!ccc!ccc!ccc!ccc!ccc!ccc!ccc!ccc
!c modif altair.partenaires

      Integer *4 i,j,cprhe,lprhe
      Real *8 matg(2*10*60*5,2*10*60*5)

!&&&      Integer *4 i,j,cprhe,lprhe
!&&&      Real *8 matg(2*3*15*5,2*3*15*5)

!ccc!ccc!ccc!ccc!ccc!ccc!ccc!ccc!ccc!cccc

      If (cprhe.EQ.1) Then
         Write (*,1) ((matg(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.2) Then
         Write (*,2) ((matg(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.3) Then
         Write (*,3) ((matg(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.4) Then
         Write (*,4) ((matg(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.5) Then
         Write (*,5) ((matg(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.6) Then
         Write (*,6) ((matg(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.7) Then
         Write (*,7) ((matg(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.8) Then
         Write (*,8) ((matg(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.9) Then
         Write (*,9) ((matg(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.10) Then
         Write (*,10) ((matg(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.11) Then
         Write (*,11) ((matg(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.12) Then
         Write (*,12) ((matg(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.13) Then
         Write (*,13) ((matg(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.14) Then
         Write (*,14) ((matg(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.15) Then
         Write (*,15) ((matg(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.16) Then
         Write (*,16) ((matg(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.17) Then
         Write (*,17) ((matg(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.18) Then
         Write (*,18) ((matg(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.19) Then
         Write (*,19) ((matg(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.20) Then
         Write (*,20) ((matg(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.21) Then
         Write (*,21) ((matg(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.22) Then
         Write (*,22) ((matg(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.23) Then
         Write (*,23) ((matg(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.24) Then
         Write (*,24) ((matg(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.25) Then
         Write (*,25) ((matg(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.26) Then
         Write (*,26) ((matg(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.27) Then
         Write (*,27) ((matg(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.28) Then
         Write (*,28) ((matg(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.29) Then
         Write (*,29) ((matg(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.30) Then
         Write (*,30) ((matg(i,j),j=1,cprhe),i=1,lprhe)
      EndIf

   1  Format(1(F8.4))
   2  Format(2(F8.4))
   3  Format(3(F8.4))
   4  Format(4(F8.4))
   5  Format(5(F8.4))
   6  Format(6(F8.4))
   7  Format(7(F8.4))
   8  Format(8(F8.4))
   9  Format(9(F8.4))
  10  Format(10(F8.4))
  11  Format(11(F8.4))
  12  Format(12(F8.4))
  13  Format(13(F8.4))
  14  Format(14(F8.4))
  15  Format(15(F8.4))
  16  Format(16(F8.4))
  17  Format(17(F8.4))
  18  Format(18(F8.4))
  19  Format(19(F8.4))
  20  Format(20(F8.4))
  21  Format(21(F8.4))
  22  Format(22(F8.4))
  23  Format(23(F8.4))
  24  Format(24(F8.4))
  25  Format(25(F8.4))
  26  Format(26(F8.4))
  27  Format(27(F8.4))
  28  Format(28(F8.4))
  29  Format(29(F8.4))
  30  Format(30(F8.4))

      Return
      End subroutine

! Subroutine pour IMPrimer une MATrice Reelle de Phase
! ***
      Subroutine ImpMatRPg(lprhe,cprhe,mat)

!ccc!ccc!ccc!ccc!ccc!ccc!ccc!ccc!ccc!ccc
!c modif altair.partenaires

      Integer *4 i,j,cprhe,lprhe
      Real *8 mat(2*10/2*60*5,2*10/2*60*5)

!&&&      Integer *4 i,j,cprhe,lprhe
!&&&      Real *8 mat(2*3/2*15*5,2*3/2*15*5)

!ccc!ccc!ccc!ccc!ccc!ccc!ccc!ccc!ccc!ccc

      If (cprhe.EQ.1) Then
         Write (*,1) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.2) Then
         Write (*,2) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.3) Then
         Write (*,3) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.4) Then
         Write (*,4) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.5) Then
         Write (*,5) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.6) Then
         Write (*,6) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.7) Then
         Write (*,7) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.8) Then
         Write (*,8) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.9) Then
         Write (*,9) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.10) Then
         Write (*,10) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.11) Then
         Write (*,11) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.12) Then
         Write (*,12) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.13) Then
         Write (*,13) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.14) Then
         Write (*,14) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.15) Then
         Write (*,15) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.16) Then
         Write (*,16) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.17) Then
         Write (*,17) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.18) Then
         Write (*,18) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.19) Then
         Write (*,19) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.20) Then
         Write (*,20) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.21) Then
         Write (*,21) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.22) Then
         Write (*,22) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.23) Then
         Write (*,23) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.24) Then
         Write (*,24) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.25) Then
         Write (*,25) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.26) Then
         Write (*,26) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.27) Then
         Write (*,27) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.28) Then
         Write (*,28) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.29) Then
         Write (*,29) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      ElseIf (cprhe.EQ.30) Then
         Write (*,30) ((mat(i,j),j=1,cprhe),i=1,lprhe)
      EndIf

   1  Format(1(F8.2))
   2  Format(2(F8.2))
   3  Format(3(F8.2))
   4  Format(4(F8.2))
   5  Format(5(F8.2))
   6  Format(6(F8.2))
   7  Format(7(F8.2))
   8  Format(8(F8.2))
   9  Format(9(F8.2))
  10  Format(10(F8.2))
  11  Format(11(F8.2))
  12  Format(12(F8.2))
  13  Format(13(F8.2))
  14  Format(14(F8.2))
  15  Format(15(F8.2))
  16  Format(16(F8.2))
  17  Format(17(F8.2))
  18  Format(18(F8.2))
  19  Format(19(F8.2))
  20  Format(20(F8.2))
  21  Format(21(F8.2))
  22  Format(22(F8.2))
  23  Format(23(F8.2))
  24  Format(24(F8.2))
  25  Format(25(F8.2))
  26  Format(26(F8.2))
  27  Format(27(F8.2))
  28  Format(28(F8.2))
  29  Format(29(F8.2))
  30  Format(30(F8.2))

      Return
      End subroutine

END MODULE aloha_scattering_matrix_utils

max_stars_repo_name: IRFM/ALOHA

max_issues_repo_name: IRFM/ALOHA

max_forks_repo_name: IRFM/ALOHA


text:
! This file created from test/mpi/f77/pt2pt/sendf.f with f77tof90
! -*- Mode: Fortran; -*-
!
!  (C) 2012 by Argonne National Laboratory.
!      See COPYRIGHT in top-level directory.
!
! This program is based on the allpair.f test from the MPICH-1 test
! (test/pt2pt/allpair.f), which in turn was inspired by a bug report from
! fsset@corelli.lerc.nasa.gov (Scott Townsend)

      program send
      use mpi
      integer ierr, errs, comm
      logical mtestGetIntraComm
      logical verbose
      common /flags/ verbose

      errs = 0
      verbose = .false.
!      verbose = .true.
      call MTest_Init( ierr )

      do while ( mtestGetIntraComm( comm, 2, .false. ) )
         call test_pair_send( comm, errs )
         call mtestFreeComm( comm )
      enddo
!
      call MTest_Finalize( errs )
!
      end
!
      subroutine test_pair_send( comm, errs )
      use mpi
      integer comm, errs
      integer rank, size, ierr, next, prev, tag, count
      integer TEST_SIZE
      parameter (TEST_SIZE=2000)
      integer status(MPI_STATUS_SIZE)
      real send_buf(TEST_SIZE), recv_buf(TEST_SIZE)
      logical verbose
      common /flags/ verbose
!
      if (verbose) then
         print *, ' Send and recv'
      endif
!
      call mpi_comm_rank( comm, rank, ierr )
      call mpi_comm_size( comm, size, ierr )
      next = rank + 1
      if (next .ge. size) next = 0
!
      prev = rank - 1
      if (prev .lt. 0) prev = size - 1
!
      tag = 1123
      count = TEST_SIZE / 5
!
      call clear_test_data(recv_buf,TEST_SIZE)
!
      if (rank .eq. 0) then
!
         call init_test_data(send_buf,TEST_SIZE)
!
         call MPI_Send(send_buf, count, MPI_REAL, next, tag, &
      &        comm, ierr)
!
         call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, &
      &                 MPI_ANY_SOURCE, MPI_ANY_TAG, comm, status, ierr)
!
         call msg_check( recv_buf, next, tag, count, status, TEST_SIZE, &
      &                   'send and recv', errs )
      else if (prev .eq. 0)  then
         call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, &
      &                 MPI_ANY_SOURCE, MPI_ANY_TAG, comm, status, ierr)

         call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, &
      &                   'send and recv', errs )
!
         call MPI_Send(recv_buf, count, MPI_REAL, prev, tag, comm, ierr)
      end if
!
      end

max_stars_repo_name: ucd-plse/mpi-error-prop

max_issues_repo_name: ucd-plse/mpi-error-prop

max_forks_repo_name: ucd-plse/mpi-error-prop


text:
	SUBROUTINE TG_VALD  ( gdattm, vdattm, iret )
C************************************************************************
C* TG_VALD								*
C*									*
C* This subroutine converts a grid time to the valid date/time.		*
C* The input string must be a full grid time.  The output time will	*
C* contain only the date and time.  The input and output strings	*
C* may be the same.							*
C*									*
C* TG_VALD  ( GDATTM, VDATTM, IRET )					*
C*									*
C* Input parameters:							*
C*	GDATTM		CHAR*		Grid date/time			*
C*									*
C* Output parameters:							*
C*	VDATTM		CHAR*		Valid date/time			*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					 -1 = invalid time		*
C*					 -2 = invalid forecast type	*
C*					 -3 = invalid forecast time	*
C**									*
C* Log:									*
C* G. Huffman/USRA	 5/89						*
C* M. desJardins/GSFC	 5/89	Fixed return codes			*
C* K. Brill/NMC		11/91	Remove string index range from sub call *
C* S. Jacobs/EAI	 9/93	Changed output format: yymmdd/hhmmVhhhmm*
C* M. desJardins/NMC	10/94	Fix output for analysis time		*
C* T. Piper/GSC		11/98	Updated prolog				*
C* B. Yin/SAIC		 5/05	Check the length of the input string	*
C************************************************************************
	CHARACTER*(*)	vdattm, gdattm
C*
	CHARACTER	ftime*12, ccc*12, ftype*1
	INTEGER		idtarr (5)
C------------------------------------------------------------------------
	iret = 0
	lengdt =  LEN ( gdattm )
C
C*	If the input string has less than 13 characters (GEMPAK format)
C*	return with the original time string
C
	IF  ( lengdt .lt. 13 )  THEN
	    vdattm = gdattm ( :lengdt)
	    RETURN
	END IF
C
C*	If the forecast type is V replace it with a blank time.
C
	ftype = gdattm (12:12)
	CALL ST_LCUC  ( ftype, ftype, ier )
	IF  ( ftype .eq. 'V' )  THEN
	    vdattm = gdattm
	    RETURN
	  ELSE
	    ftime = gdattm (13: )
	END IF
C
C*	Return if the forecast time is blank.
C
	IF  ( ftime .eq. ' ' )  THEN
	    vdattm = gdattm ( :12)
	    RETURN
	END IF
C
C*	Get the forecast range.  A sets the i in ihhhmm to zero.
C
	CALL TG_IFTM  ( 'A', ftime, ihhhmm, iret )
	ihour = ihhhmm / 100
	imin  = ihhhmm - ihour * 100
	IF  ( iret .ne. 0 )  THEN
	    vdattm = ' '
	    RETURN
	END IF
C
C*	Break the date/time into 5 integers.
C
	ccc = gdattm ( :11 )
	CALL TI_CTOI  ( ccc, idtarr, ier )
	IF  ( ier .ne. 0 )  THEN
	    iret   = -1
	    vdattm = ' '
	    RETURN
	END IF
C
C*	Add forecast minutes.
C
	idtarr (5) = idtarr (5) + imin
	DO  WHILE  ( idtarr (5) .ge. 60 )
	    idtarr (5) = idtarr (5) - 60
	    idtarr (4) = idtarr (4) + 1
	END DO
C
C*	Add forecast hours.
C
	idtarr (4) = idtarr (4) + ihour
	DO  WHILE  ( idtarr (4) .ge. 24 )
	    idtarr (4) = idtarr (4) - 24
	    CALL TI_ADDD  ( idtarr, idtarr, ier )
	END DO
C
C*	Convert the date/time back to character.
C
	CALL TI_ITOC  ( idtarr, vdattm, ier )
	CALL ST_LSTR  ( vdattm, lenvld, ier )
	vdattm = vdattm (:lenvld) // 'V' // ftime
C*
	RETURN
	END

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


text:
    SUBROUTINE testPairedData(ifltab1, messageUnit, status)
!
!    Test basic writing and reading of Paired Data functions
!    Internal function
!
      implicit none
!
      integer messageUnit, status
      integer(8) ifltab1(*)
!
      real data1(5110), data2(5110)
      double precision ddata1(5110), ddata2(5110)
      character cpath1*100
      character*12 unitsIndependent, typeIndependent, unitsDependent, typeDependent, ctemp
      character labels(100)*50
      character labelsRead(100)*50
      integer ipos, iplan
      integer nvals, i, nOrdinates, n, j, ncurves
      integer numberOrdinates, numberCurves, iHorizontal
      integer userHeader(10), numberUserHeaderRead
      logical labelsStored

      common /lchk/ lcheck
      logical lcheck

!
      WRITE(messageUnit, *)'Begin testPairedData'
      nOrdinates = 10
      do i=1, nOrdinates
       data1(i) =FLOAT(i)
      end do

      do  i=11, 20
       data1(i) = FLOAT(i) * 100.0
      end do
  !
!
 1  Format('Paired Data test FAILED')

    !goto 530
    cpath1 = '/Paired Data/One Curve/Stage-Flow/F/No Labels/F/'

    call zspd (ifltab1, cpath1, nOrdinates, 1, 1, 'Feet', 'UNT', 'CFS', 'UNT', data1, '', 0, userHeader, 0, 0, status)
    if (status.ne.0) go to 900
    call zinqir(ifltab1, 'error', ctemp, status)
    if (status.ne.0) go to 900

!   Check
    call zrpd (ifltab1, cpath1, numberOrdinates, numberCurves, iHorizontal, &
        unitsIndependent, typeIndependent, unitsDependent, typeDependent, &
        data2, 1000, nvals, labels, 0, labelsStored, &
        userHeader, 0, numberUserHeaderRead, status)
    if (status.ne.0) go to 900
    call zinqir(ifltab1, 'error', ctemp, status)
    if (status.ne.0) go to 900

    call checkNumbers(10, numberOrdinates, 'testPairedData numberOrdinates stored, loc 10', status)
    if (status.ne.0) go to 900
    call checkNumbers(1, numberCurves, 'testPairedData numberCurves stored, loc 10', status)
    if (status.ne.0) go to 900
    call checkNumbers(1, iHorizontal, 'testPairedData iHorizontal stored, loc 10', status)
    if (status.ne.0) go to 900
    call checkString('Feet', unitsIndependent, 'testPairedData units 1, loc 10', status)
    if (status.ne.0) go to 900
    call checkString('UNT', typeIndependent, 'testPairedData type 1, loc 10', status)
    if (status.ne.0) go to 900
    call checkString('CFS', unitsDependent, 'testPairedData units 2, loc 10', status)
    if (status.ne.0) go to 900
    call checkString('UNT', typeDependent, 'testPairedData type 2, loc 10', status)
    if (status.ne.0) go to 900
     call checkFloats(data1, data2, nvals, 'testPairedData Values, loc 10', status)
    if (status.ne.0) go to 900
    !write(messageUnit, *)'Passed loc 10'
    !write(messageUnit, *)' '

    ! test single curve with a label
    cpath1 = '/Paired Data/One Curve/Stage-Flow/F/With Labels/F/'
    labels(1) = "My Label"
    call zspd (ifltab1, cpath1, nOrdinates, 1, 1, 'Feet', 'UNT', 'CFS', 'UNT', data1, labels, .true., userHeader, 0, 0, status)
    if (status.ne.0) go to 900
    call zinqir(ifltab1, 'error', ctemp, status)
    if (status.ne.0) go to 900

!   Check
    call zrpd (ifltab1, cpath1, numberOrdinates, numberCurves, iHorizontal, &
        unitsIndependent, typeIndependent, unitsDependent, typeDependent, &
        data2, 1000, nvals, labelsRead, 50, labelsStored, &
        userHeader, 0, numberUserHeaderRead, status)
    if (status.ne.0) go to 900
    call zinqir(ifltab1, 'error', ctemp, status)
    if (status.ne.0) go to 900

    call checkNumbers(nOrdinates, numberOrdinates, 'testPairedData numberOrdinates stored, loc 20', status)
    if (status.ne.0) go to 900
    call checkNumbers(1, numberCurves, 'testPairedData numberCurves stored, loc 20', status)
    if (status.ne.0) go to 900
    call checkNumbers(1, iHorizontal, 'testPairedData iHorizontal stored, loc 20', status)
    if (status.ne.0) go to 900
    call checkString('Feet', unitsIndependent, 'testPairedData units 1, loc 20', status)
    if (status.ne.0) go to 900
    call checkString('UNT', typeIndependent, 'testPairedData type 1, loc 20', status)
    if (status.ne.0) go to 900
    call checkString('CFS', unitsDependent, 'testPairedData units 2, loc 20', status)
    if (status.ne.0) go to 900
    call checkString('UNT', typeDependent, 'testPairedData type 2, loc 20', status)
    if (status.ne.0) go to 900
     call checkFloats(data1, data2, nvals, 'testPairedData Values, loc 20', status)
    if (status.ne.0) go to 900
    if (.not.labelsStored) then
        write(messageUnit, *)'Labels stored false; failed read, testPairedData, loc 20'
        status = -1
        go to 900
    endif
   call checkString(labels(1), labelsRead(1), 'testPairedData labels, loc 20', status)
    if (status.ne.0) go to 900

   ! test 50 curves with a labels
    cpath1 = '/Paired Data/Fifty Curves/Stage-Flow/F/With Labels/Floats/'
    ncurves = 50
    nOrdinates = 100
    do i=1,(ncurves+1)
       write (labels(i), 199) i
199    format('Curve ', I2)
       do j=1,nOrdinates
           n = j + ((i-1) *nOrdinates )
           data1(n) = (i * 1000) + j
           ddata1(n) = data1(n)
       end do
    end do
    call zspd (ifltab1, cpath1, nOrdinates, ncurves, 1, 'Feet', 'UNT', 'CFS', 'UNT', data1, labels, .true.,&
     userHeader, 0, 0, status)
    if (status.ne.0) go to 900
    call zinqir(ifltab1, 'error', ctemp, status)
    if (status.ne.0) go to 900

!   Check
    call zrpd (ifltab1, cpath1, numberOrdinates, numberCurves, iHorizontal, &
        unitsIndependent, typeIndependent, unitsDependent, typeDependent, &
        data2, 5110, nvals, labelsRead, 50, labelsStored, &
        userHeader, 0, numberUserHeaderRead, status)
    if (status.ne.0) go to 900
    call zinqir(ifltab1, 'error', ctemp, status)
    if (status.ne.0) go to 900

    call checkNumbers(nOrdinates, numberOrdinates, 'testPairedData numberOrdinates stored, loc 30', status)
    if (status.ne.0) go to 900
    call checkNumbers(ncurves, numberCurves, 'testPairedData numberCurves stored, loc 30', status)
    if (status.ne.0) go to 900
    call checkNumbers(1, iHorizontal, 'testPairedData iHorizontal stored, loc 30', status)
    if (status.ne.0) go to 900
    call checkNumbers(5100, nvals, 'testPairedData iHorizontal stored, loc 30', status)
    if (status.ne.0) go to 900
    call checkString('Feet', unitsIndependent, 'testPairedData units 1, loc 30', status)
    if (status.ne.0) go to 900
    call checkString('UNT', typeIndependent, 'testPairedData type 1, loc 30', status)
    if (status.ne.0) go to 900
    call checkString('CFS', unitsDependent, 'testPairedData units 2, loc 30', status)
    if (status.ne.0) go to 900
    call checkString('UNT', typeDependent, 'testPairedData type 2, loc 30', status)
    if (status.ne.0) go to 900
     call checkFloats(data1, data2, nvals, 'testPairedData Values, loc 30', status)
    if (status.ne.0) go to 900
    if (.not.labelsStored) then
        write(messageUnit, *)'Labels stored false; failed read, testPairedData, loc 20'
        status = -1
        go to 900
    endif
    do i=1,ncurves
        call checkString(labels(i), labelsRead(i), 'testPairedData labels, loc 30', status)
        if (status.ne.0) go to 900
    end do

     !   Read floats as doubles
   cpath1 = '/Paired Data/Fifty Curves/Stage-Flow/F/With Labels/Floats/'
    call zrpdd (ifltab1, cpath1, numberOrdinates, numberCurves, iHorizontal, &
        unitsIndependent, typeIndependent, unitsDependent, typeDependent, &
        ddata2, 5110, nvals, labelsRead, 50, labelsStored, &
        userHeader, 0, numberUserHeaderRead, status)
    if (status.ne.0) go to 900
    call zinqir(ifltab1, 'error', ctemp, status)
    if (status.ne.0) go to 900

    call checkNumbers(nOrdinates, numberOrdinates, 'testPairedData numberOrdinates stored, loc 35', status)
    if (status.ne.0) go to 900
    call checkNumbers(ncurves, numberCurves, 'testPairedData numberCurves stored, loc 35', status)
    if (status.ne.0) go to 900
    call checkNumbers(1, iHorizontal, 'testPairedData iHorizontal stored, loc 35', status)
    if (status.ne.0) go to 900
    call checkNumbers(5100, nvals, 'testPairedData iHorizontal stored, loc 35', status)
    if (status.ne.0) go to 900
    call checkString('Feet', unitsIndependent, 'testPairedData units 1, loc 35', status)
    if (status.ne.0) go to 900
    call checkString('UNT', typeIndependent, 'testPairedData type 1, loc 35', status)
    if (status.ne.0) go to 900
    call checkString('CFS', unitsDependent, 'testPairedData units 2, loc 35', status)
    if (status.ne.0) go to 900
    call checkString('UNT', typeDependent, 'testPairedData type 2, loc 35', status)
    if (status.ne.0) go to 900
     call checkDoubles(ddata1, ddata2, nvals, 'testPairedData Values, loc 35', status)
    if (status.ne.0) go to 900
    if (.not.labelsStored) then
        write(messageUnit, *)'Labels stored false; failed read, testPairedData, loc 35'
        status = -1
        go to 900
    endif
    do i=1,ncurves
        call checkString(labels(i), labelsRead(i), 'testPairedData labels, loc 35', status)
        if (status.ne.0) go to 900
    end do

   ! Now, double precision
    cpath1 = '/Paired Data/Fifty Curves/Stage-Flow/F/With Labels/Doubles/'
    ncurves = 50
    nOrdinates = 100
    do i=1,(ncurves+1)
       write (labels(i), 199) i
       do  j=1,nOrdinates
           n = j + ((i-1) *nOrdinates )
           ddata1(n) = (i * 1000) + j
       end do
    end do
    call zspdd (ifltab1, cpath1, nOrdinates, ncurves, 1, 'Feet', 'UNT', 'CFS', 'UNT', ddata1, labels, .true.,&
     userHeader, 0, 0, status)
    if (status.ne.0) go to 900
    call zinqir(ifltab1, 'error', ctemp, status)
    if (status.ne.0) go to 900

!   Check
    call zrpdd (ifltab1, cpath1, numberOrdinates, numberCurves, iHorizontal, &
        unitsIndependent, typeIndependent, unitsDependent, typeDependent, &
        ddata2, 5110, nvals, labelsRead, 50, labelsStored, &
        userHeader, 0, numberUserHeaderRead, status)
    if (status.ne.0) go to 900
    call zinqir(ifltab1, 'error', ctemp, status)
    if (status.ne.0) go to 900

    call checkNumbers(nOrdinates, numberOrdinates, 'testPairedData numberOrdinates stored, loc 40', status)
    if (status.ne.0) go to 900
    call checkNumbers(ncurves, numberCurves, 'testPairedData numberCurves stored, loc 40', status)
    if (status.ne.0) go to 900
    call checkNumbers(1, iHorizontal, 'testPairedData iHorizontal stored, loc 40', status)
    if (status.ne.0) go to 900
    call checkNumbers(5100, nvals, 'testPairedData iHorizontal stored, loc 40', status)
    if (status.ne.0) go to 900
    call checkString('Feet', unitsIndependent, 'testPairedData units 1, loc 40', status)
    if (status.ne.0) go to 900
    call checkString('UNT', typeIndependent, 'testPairedData type 1, loc 40', status)
    if (status.ne.0) go to 900
    call checkString('CFS', unitsDependent, 'testPairedData units 2, loc 40', status)
    if (status.ne.0) go to 900
    call checkString('UNT', typeDependent, 'testPairedData type 2, loc 40', status)
    if (status.ne.0) go to 900
     call checkDoubles(ddata1, ddata2, nvals, 'testPairedData Values, loc 40', status)
    if (status.ne.0) go to 900
    if (.not.labelsStored) then
        write(messageUnit, *)'Labels stored false; failed read, testPairedData, loc 40'
        status = -1
        go to 900
    endif
    do i=1,ncurves
        call checkString(labels(i), labelsRead(i), 'testPairedData labels, loc 40', status)
        if (status.ne.0) go to 900
    end do

   !   Read doubles as floats
   cpath1 = '/Paired Data/Fifty Curves/Stage-Flow/F/With Labels/Doubles/'
    call zrpd (ifltab1, cpath1, numberOrdinates, numberCurves, iHorizontal, &
        unitsIndependent, typeIndependent, unitsDependent, typeDependent, &
        data2, 5110, nvals, labelsRead, 50, labelsStored, &
        userHeader, 0, numberUserHeaderRead, status)
    if (status.ne.0) go to 900
    call zinqir(ifltab1, 'error', ctemp, status)
    if (status.ne.0) go to 900

    call checkNumbers(nOrdinates, numberOrdinates, 'testPairedData numberOrdinates stored, loc 50', status)
    if (status.ne.0) go to 900
    call checkNumbers(ncurves, numberCurves, 'testPairedData numberCurves stored, loc 50', status)
    if (status.ne.0) go to 900
    call checkNumbers(1, iHorizontal, 'testPairedData iHorizontal stored, loc 50', status)
    if (status.ne.0) go to 900
    call checkNumbers(5100, nvals, 'testPairedData iHorizontal stored, loc 50', status)
    if (status.ne.0) go to 900
    call checkString('Feet', unitsIndependent, 'testPairedData units 1, loc 50', status)
    if (status.ne.0) go to 900
    call checkString('UNT', typeIndependent, 'testPairedData type 1, loc 50', status)
    if (status.ne.0) go to 900
    call checkString('CFS', unitsDependent, 'testPairedData units 2, loc 50', status)
    if (status.ne.0) go to 900
    call checkString('UNT', typeDependent, 'testPairedData type 2, loc 50', status)
    if (status.ne.0) go to 900
     call checkFloats(data1, data2, nvals, 'testPairedData Values, loc 50', status)
    if (status.ne.0) go to 900
    if (.not.labelsStored) then
        write(messageUnit, *)'Labels stored false; failed read, testPairedData, loc 50'
        status = -1
        go to 900
    endif
    do i=1,ncurves
        call checkString(labels(i), labelsRead(i), 'testPairedData labels, loc 50', status)
        if (status.ne.0) go to 900
    end do

   !   Read floats as doubles
   cpath1 = '/Paired Data/Fifty Curves/Stage-Flow/F/With Labels/Floats/'
    call zrpdd (ifltab1, cpath1, numberOrdinates, numberCurves, iHorizontal, &
        unitsIndependent, typeIndependent, unitsDependent, typeDependent, &
        ddata2, 5110, nvals, labelsRead, 50, labelsStored, &
        userHeader, 0, numberUserHeaderRead, status)
    if (status.ne.0) go to 900
    call zinqir(ifltab1, 'error', ctemp, status)
    if (status.ne.0) go to 900

    call checkNumbers(nOrdinates, numberOrdinates, 'testPairedData numberOrdinates stored, loc 60', status)
    if (status.ne.0) go to 900
    call checkNumbers(ncurves, numberCurves, 'testPairedData numberCurves stored, loc 60', status)
    if (status.ne.0) go to 900
    call checkNumbers(1, iHorizontal, 'testPairedData iHorizontal stored, loc 60', status)
    if (status.ne.0) go to 900
    call checkNumbers(5100, nvals, 'testPairedData iHorizontal stored, loc 60', status)
    if (status.ne.0) go to 900
    call checkString('Feet', unitsIndependent, 'testPairedData units 1, loc 60', status)
    if (status.ne.0) go to 900
    call checkString('UNT', typeIndependent, 'testPairedData type 1, loc 60', status)
    if (status.ne.0) go to 900
    call checkString('CFS', unitsDependent, 'testPairedData units 2, loc 60', status)
    if (status.ne.0) go to 900
    call checkString('UNT', typeDependent, 'testPairedData type 2, loc 60', status)
    if (status.ne.0) go to 900
     call checkDoubles(ddata1, ddata2, nvals, 'testPairedData Values, loc 60', status)
    if (status.ne.0) go to 900
    if (.not.labelsStored) then
        write(messageUnit, *)'Labels stored false; failed read, testPairedData, loc 60'
        status = -1
        go to 900
    endif
    do i=1,ncurves
        call checkString(labels(i), labelsRead(i), 'testPairedData labels, loc 60', status)
        if (status.ne.0) go to 900
    end do

 ! Now, double precision, one curve at at a time
  530   continue
    cpath1 = '/Paired Data/Fifty Curves - one at a time/Stage-Flow/F/With Labels/Doubles/'
    ncurves = 50
    nOrdinates = 100
    do i=1,(ncurves+1)
       write (labels(i), 199) i
       do j=1,nOrdinates
           n = j + ((i-1) *nOrdinates )
           ddata1(n) = (i * 1000) + j
       end do
    end do
    iplan = 10
    call zspdd (ifltab1, cpath1, nOrdinates, ncurves, 1, 'Feet', 'UNT', 'CFS', 'UNT', ddata1, labels, .true., &
     userHeader, 0, iplan, status)
    if (status.ne.0) go to 900
    call zinqir(ifltab1, 'error', ctemp, status)
    if (status.ne.0) go to 900

    do i=1,ncurves
        iplan = 11
        ipos = (i * nOrdinates) + 1
        call zspdd(ifltab1, cpath1, nOrdinates, i, 1, '', '', '', '', ddata1(ipos), labels(i), .true., &
        userHeader, 0, iplan, status)
        if (status.ne.0) go to 900
        call zinqir(ifltab1, 'error', ctemp, status)
        if (status.ne.0) go to 900
    end do

!   Check
    call zrpdd(ifltab1, cpath1, numberOrdinates, numberCurves, iHorizontal, &
        unitsIndependent, typeIndependent, unitsDependent, typeDependent, &
        ddata2, 5110, nvals, labelsRead, 50, labelsStored, &
        userHeader, 0, numberUserHeaderRead, status)
    if (status.ne.0) go to 900
    call zinqir(ifltab1, 'error', ctemp, status)
    if (status.ne.0) go to 900

    call checkNumbers(nOrdinates, numberOrdinates, 'testPairedData numberOrdinates stored, loc 140', status)
    if (status.ne.0) go to 900
    call checkNumbers(ncurves, numberCurves, 'testPairedData numberCurves stored, loc 140', status)
    if (status.ne.0) go to 900
    call checkNumbers(1, iHorizontal, 'testPairedData iHorizontal stored, loc 140', status)
    if (status.ne.0) go to 900
    call checkNumbers(5100, nvals, 'testPairedData iHorizontal stored, loc 140', status)
    if (status.ne.0) go to 900
    call checkString('Feet', unitsIndependent, 'testPairedData units 1, loc 140', status)
    if (status.ne.0) go to 900
    call checkString('UNT', typeIndependent, 'testPairedData type 1, loc 140', status)
    if (status.ne.0) go to 900
    call checkString('CFS', unitsDependent, 'testPairedData units 2, loc 140', status)
    if (status.ne.0) go to 900
    call checkString('UNT', typeDependent, 'testPairedData type 2, loc 140', status)
    if (status.ne.0) go to 900
     call checkDoubles(ddata1, ddata2, nvals, 'testPairedData Values, loc 140', status)
    if (status.ne.0) go to 900
    if (.not.labelsStored) then
        write(messageUnit, *)'Labels stored false; failed read, testPairedData, loc 140'
        status = -1
        go to 900
    endif
    do i=1,ncurves
        call checkString(labels(i), labelsRead(i), 'testPairedData labels, loc 140', status)
        if (status.ne.0) go to 900
    end do

    !  Now with extended labels
    cpath1 = '/Paired Data/Fifty Curves - one at a time/Stage-Flow/F/Extended Labels/Doubles/'
    ncurves = 50
    nOrdinates = 100
    do i=1,(ncurves+1)
       write (labels(i), 730) i
730    format('Extended label for this curve, number ',I2.2)
       do j=1,nOrdinates
           n = j + ((i-1) *nOrdinates )
           ddata1(n) = (i * 1000) + j
           data1(n) = ddata1(n)
       end do
    end do
    iplan = 10
    call zspdd (ifltab1, cpath1, nOrdinates, ncurves, 1, 'Feet', 'UNT', 'CFS', 'UNT', ddata1, labels, .true.,&
     userHeader, 0, iplan, status)
    if (status.ne.0) go to 900
    call zinqir(ifltab1, 'error', ctemp, status)
    if (status.ne.0) go to 900

    do i=1,ncurves
        iplan = 11
        ipos = (i * nOrdinates) + 1
        call zspdd(ifltab1, cpath1, nOrdinates, i, 1, '', '', '', '', ddata1(ipos), labels(i), .true., userHeader, 0, iplan, status)
        if (status.ne.0) go to 900
        call zinqir(ifltab1, 'error', ctemp, status)
        if (status.ne.0) go to 900
    end do

!   Check
    call zrpdd(ifltab1, cpath1, numberOrdinates, numberCurves, iHorizontal, &
        unitsIndependent, typeIndependent, unitsDependent, typeDependent, &
        ddata2, 5110, nvals, labelsRead, 50, labelsStored, &
        userHeader, 0, numberUserHeaderRead, status)
    if (status.ne.0) go to 900
    call zinqir(ifltab1, 'error', ctemp, status)
    if (status.ne.0) go to 900

    call checkNumbers(nOrdinates, numberOrdinates, 'testPairedData numberOrdinates stored, loc 150', status)
    if (status.ne.0) go to 900
    call checkNumbers(ncurves, numberCurves, 'testPairedData numberCurves stored, loc 150', status)
    if (status.ne.0) go to 900
    call checkNumbers(1, iHorizontal, 'testPairedData iHorizontal stored, loc 150', status)
    if (status.ne.0) go to 900
    call checkNumbers(5100, nvals, 'testPairedData iHorizontal stored, loc 150', status)
    if (status.ne.0) go to 900
    call checkString('Feet', unitsIndependent, 'testPairedData units 1, loc 150', status)
    if (status.ne.0) go to 900
    call checkString('UNT', typeIndependent, 'testPairedData type 1, loc 150', status)
    if (status.ne.0) go to 900
    call checkString('CFS', unitsDependent, 'testPairedData units 2, loc 150', status)
    if (status.ne.0) go to 900
    call checkString('UNT', typeDependent, 'testPairedData type 2, loc 150', status)
    if (status.ne.0) go to 900
     call checkDoubles(ddata1, ddata2, nvals, 'testPairedData Values, loc 150', status)
    if (status.ne.0) go to 900
    if (.not.labelsStored) then
        write(messageUnit, *)'Labels stored false; failed read, testPairedData, loc 150'
        status = -1
        go to 900
    endif
    do i=1,ncurves
        call checkString(labels(i), labelsRead(i), 'testPairedData labels, loc 150', status)
        if (status.ne.0) go to 900
    end do

   !   Read doubles as floats
    call zrpd (ifltab1, cpath1, numberOrdinates, numberCurves, iHorizontal, &
        unitsIndependent, typeIndependent, unitsDependent, typeDependent, &
        data2, 5110, nvals, labelsRead, 50, labelsStored, &
        userHeader, 0, numberUserHeaderRead, status)

    if (status.ne.0) go to 900
    call zinqir(ifltab1, 'error', ctemp, status)
    if (status.ne.0) go to 900

    call checkNumbers(nOrdinates, numberOrdinates, 'testPairedData numberOrdinates stored, loc 160', status)
    if (status.ne.0) go to 900
    call checkNumbers(ncurves, numberCurves, 'testPairedData numberCurves stored, loc 160', status)
    if (status.ne.0) go to 900
    call checkNumbers(1, iHorizontal, 'testPairedData iHorizontal stored, loc 160', status)
    if (status.ne.0) go to 900
    call checkNumbers(5100, nvals, 'testPairedData iHorizontal stored, loc 160', status)
    if (status.ne.0) go to 900
    call checkString('Feet', unitsIndependent, 'testPairedData units 1, loc 160', status)
    if (status.ne.0) go to 900
    call checkString('UNT', typeIndependent, 'testPairedData type 1, loc 160', status)
    if (status.ne.0) go to 900
    call checkString('CFS', unitsDependent, 'testPairedData units 2, loc 160', status)
    if (status.ne.0) go to 900
    call checkString('UNT', typeDependent, 'testPairedData type 2, loc 160', status)
    if (status.ne.0) go to 900
     call checkFloats(data1, data2, nvals, 'testPairedData Values, loc 160', status)
    if (status.ne.0) go to 900
    if (.not.labelsStored) then
        write(messageUnit, *)'Labels stored false; failed read, testPairedData, loc 160'
        status = -1
        go to 900
    endif
    do i=1,ncurves
        call checkString(labels(i), labelsRead(i), 'testPairedData labels, loc 160', status)
        if (status.ne.0) go to 900
   end do

!
 800   Continue
       if (lcheck) call zcheckFile(ifltab1, status)
       if (status.eq.0) then
            Write(messageUnit, 810)
 810        Format('Paired Data Series Passed Successfully')
        else
            Write(messageUnit, 820)
 820        Format('File Check FAILED in Paired Data')
        endif
       return
!
 900    Continue
        write(messageUnit, 1)
 910    Continue
        if (status.eq.0) status = -1
        return
        end

max_stars_repo_name: HydrologicEngineeringCenter/heclib

max_issues_repo_name: HydrologicEngineeringCenter/heclib

max_forks_repo_name: HydrologicEngineeringCenter/heclib


text:
      PROGRAM FM002

C     COMMENT SECTION                                                   00010002
C                                                                       00020002
C     FM002                                                             00030002
C                                                                       00040002
C         THIS ROUTINE CHECKS THAT COMMENT LINES WHICH HAVE VALID       00050002
C     FORTRAN STATEMENTS DO NOT AFFECT THE EXECUTION OF THE PROGRAM     00060002
C     IN ANY WAY.                                                       00070002
C                                                                       00080002
C      REFERENCES                                                       00090002
C        AMERICAN NATIONAL STANDARD PROGRAMMING LANGUAGE FORTRAN,       00100002
C              X3.9-1978                                                00110002
C                                                                       00120002
C                   SECTION 3.2.1, COMMENT LINE                         00130002
C                                                                       00140002
C      **********************************************************       00150002
C                                                                       00160002
C         A COMPILER VALIDATION SYSTEM FOR THE FORTRAN LANGUAGE         00170002
C     BASED ON SPECIFICATIONS AS DEFINED IN AMERICAN NATIONAL STANDARD  00180002
C     PROGRAMMING LANGUAGE FORTRAN X3.9-1978, HAS BEEN DEVELOPED BY THE 00190002
C     FEDERAL COBOL COMPILER TESTING SERVICE.  THE FORTRAN COMPILER     00200002
C     VALIDATION SYSTEM (FCVS) CONSISTS OF AUDIT ROUTINES, THEIR RELATED00210002
C     DATA, AND AN EXECUTIVE SYSTEM.  EACH AUDIT ROUTINE IS A FORTRAN   00220002
C     PROGRAM, SUBPROGRAM OR FUNCTION WHICH INCLUDES TESTS OF SPECIFIC  00230002
C     LANGUAGE ELEMENTS AND SUPPORTING PROCEDURES INDICATING THE RESULT 00240002
C     OF EXECUTING THESE TESTS.                                         00250002
C                                                                       00260002
C         THIS PARTICULAR PROGRAM/SUBPROGRAM/FUNCTION CONTAINS FEATURES 00270002
C     FOUND ONLY IN THE SUBSET AS DEFINED IN X3.9-1978.                 00280002
C                                                                       00290002
C         SUGGESTIONS AND COMMENTS SHOULD BE FORWARDED TO -             00300002
C                                                                       00310002
C              NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY           00320002
C                   SOFTWARE STANDARDS VALIDATION GROUP                 00330002
C                          BUILDING 225  RM A266                        00340002
C                         GAITHERSBURG, MD  20899                       00350002
C      **********************************************************       00360002
C                                                                       00370002
C                                                                       00380002
C                                                                       00390002
C     INITIALIZATION SECTION                                            00400002
C                                                                       00410002
C     INITIALIZE CONSTANTS                                              00420002
C      **************                                                   00430002
C     I01 CONTAINS THE LOGICAL UNIT NUMBER FOR THE CARD READER.         00440002
      I01 = 5                                                           00450002
C     I02 CONTAINS THE LOGICAL UNIT NUMBER FOR THE PRINTER.             00460002
      I02 = 6                                                           00470002
C     SYSTEM ENVIRONMENT SECTION                                        00480002
C                                                                       00490002
CX010    THIS CARD IS REPLACED BY CONTENTS OF FEXEC X-010 CONTROL CARD. 00500002
C     THE CX010 CARD IS FOR OVERRIDING THE PROGRAM DEFAULT I01 = 5      00510002
C     (UNIT NUMBER FOR CARD READER).                                    00520002
CX011    THIS CARD IS REPLACED BY CONTENTS OF FEXEC X-011 CONTROL CARD. 00530002
C     THE CX011 CARD IS FOR SYSTEMS WHICH REQUIRE ADDITIONAL            00540002
C     FORTRAN STATEMENTS FOR FILES ASSOCIATED WITH CX010 ABOVE.         00550002
C                                                                       00560002
CX020    THIS CARD IS REPLACED BY CONTENTS OF FEXEC X-020 CONTROL CARD. 00570002
C     THE CX020 CARD IS FOR OVERRIDING THE PROGRAM DEFAULT I02 = 6      00580002
C     (UNIT NUMBER FOR PRINTER).                                        00590002
CX021    THIS CARD IS REPLACED BY CONTENTS OF FEXEC X-021 CONTROL CARD. 00600002
C     THE CX021 CARD IS FOR SYSTEMS WHICH REQUIRE ADDITIONAL            00610002
C     FORTRAN STATEMENTS FOR FILES ASSOCIATED WITH CX020 ABOVE.         00620002
C                                                                       00630002
      IVPASS=0                                                          00640002
      IVFAIL=0                                                          00650002
      IVDELE=0                                                          00660002
      ICZERO=0                                                          00670002
C                                                                       00680002
C     WRITE PAGE HEADERS                                                00690002
      WRITE (I02,90000)                                                 00700002
      WRITE (I02,90001)                                                 00710002
      WRITE (I02,90002)                                                 00720002
      WRITE (I02, 90002)                                                00730002
      WRITE (I02,90003)                                                 00740002
      WRITE (I02,90002)                                                 00750002
      WRITE (I02,90004)                                                 00760002
      WRITE (I02,90002)                                                 00770002
      WRITE (I02,90011)                                                 00780002
      WRITE (I02,90002)                                                 00790002
      WRITE (I02,90002)                                                 00800002
      WRITE (I02,90005)                                                 00810002
      WRITE (I02,90006)                                                 00820002
      WRITE (I02,90002)                                                 00830002
C     TEST SECTION                                                      00840002
C                                                                       00850002
   41 CONTINUE                                                          00860002
      IVTNUM=4                                                          00870002
C                                                                       00880002
C      ****  TEST 004  ****                                             00890002
C     TEST 004  -  BLANK COMMENT LINE                                   00900002
C                                                                       00910002
      IF (ICZERO) 30040,40,30040                                        00920002
   40 CONTINUE                                                          00930002
      IVON01=4                                                          00940002
C                                                                       00950002
      GO TO 40040                                                       00960002
30040 IVDELE=IVDELE+1                                                   00970002
      WRITE (I02,80003) IVTNUM                                          00980002
      IF (ICZERO) 40040, 51, 40040                                      00990002
40040 IF (IVON01 - 4) 20040, 10040, 20040                               01000002
10040 IVPASS=IVPASS+1                                                   01010002
      WRITE (I02,80001) IVTNUM                                          01020002
      GO TO 51                                                          01030002
20040 IVFAIL=IVFAIL+1                                                   01040002
      IVCOMP=IVON01                                                     01050002
      IVCORR=4                                                          01060002
      WRITE (I02,80004) IVTNUM,IVCOMP,IVCORR                            01070002
   51 CONTINUE                                                          01080002
      IVTNUM=5                                                          01090002
C                                                                       01100002
C      ****  TEST 005  ****                                             01110002
C     TEST 005  - GO TO IN COMMENT LINE                                 01120002
C                                                                       01130002
      IF (ICZERO) 30050, 50, 30050                                      01140002
   50 CONTINUE                                                          01150002
      IVON01 = 3                                                        01160002
C     GO TO 20050                                                       01170002
      IVON01=5                                                          01180002
      GO TO 40050                                                       01190002
30050 IVDELE=IVDELE+1                                                   01200002
      WRITE (I02,80003) IVTNUM                                          01210002
      IF (ICZERO) 40050, 61, 40050                                      01220002
40050 IF (IVON01 - 5) 20050,10050,20050                                 01230002
10050 IVPASS=IVPASS+1                                                   01240002
      WRITE (I02,80001) IVTNUM                                          01250002
      GO TO 61                                                          01260002
20050 IVFAIL=IVFAIL+1                                                   01270002
      IVCOMP=IVON01                                                     01280002
      IVCORR=5                                                          01290002
      WRITE (I02,80004) IVTNUM,IVCOMP,IVCORR                            01300002
   61 CONTINUE                                                          01310002
      IVTNUM=6                                                          01320002
C                                                                       01330002
C      ****  TEST 006  ****                                             01340002
C     TEST 006 - INTEGER ASSIGNMENT STATEMENT IN COMMENT LINE           01350002
C                                                                       01360002
      IF (ICZERO) 30060,60,30060                                        01370002
   60 CONTINUE                                                          01380002
      IVON01=6                                                          01390002
C     IVON01=1                                                          01400002
      GO TO 40060                                                       01410002
30060 IVDELE=IVDELE+1                                                   01420002
      WRITE (I02,80003) IVTNUM                                          01430002
      IF (ICZERO) 40060,71,40060                                        01440002
40060 IF (IVON01-6) 20060,10060,20060                                   01450002
10060 IVPASS=IVPASS+1                                                   01460002
      WRITE (I02,80001) IVTNUM                                          01470002
      GO TO 71                                                          01480002
20060 IVFAIL=IVFAIL+1                                                   01490002
      IVCOMP=IVON01                                                     01500002
      IVCORR=6                                                          01510002
      WRITE (I02,80004) IVTNUM,IVCOMP,IVCORR                            01520002
   71 CONTINUE                                                          01530002
      IVTNUM=7                                                          01540002
C                                                                       01550002
C      ****  TEST  007  ****                                            01560002
C     TEST 007 - INTEGER ASSIGNMENT STATEMENT IN COMMENT LINE           01570002
C                INTEGER EXPRESSION TO RIGHT OF =                       01580002
C                                                                       01590002
      IF (ICZERO) 30070,70,30070                                        01600002
   70 CONTINUE                                                          01610002
      IVON02=6                                                          01620002
      IVON01=7                                                          01630002
C     IVON01= 3*IVON02                                                  01640002
      GO TO 40070                                                       01650002
30070 IVDELE=IVDELE+1                                                   01660002
      WRITE (I02,80003) IVTNUM                                          01670002
      IF (ICZERO) 40070,81,40070                                        01680002
40070 IF (IVON01-7) 20070,10070,20070                                   01690002
10070 IVPASS=IVPASS+1                                                   01700002
      WRITE (I02,80001) IVTNUM                                          01710002
      GO TO 81                                                          01720002
20070 IVFAIL=IVFAIL+1                                                   01730002
      IVCOMP=IVON01                                                     01740002
      IVCORR=7                                                          01750002
      WRITE (I02,80004) IVTNUM,IVCOMP,IVCORR                            01760002
   81 CONTINUE                                                          01770002
      IVTNUM=8                                                          01780002
C                                                                       01790002
C      ****  TEST 008  ****                                             01800002
C     TEST 008 - IF STATEMENT IN COMMENT LINE                           01810002
C                                                                       01820002
      IF (ICZERO) 30080,80,30080                                        01830002
   80 CONTINUE                                                          01840002
      IVON01=300                                                        01850002
C     IF (IVON01) 20080,20080,20080                                     01860002
      IVON01=8                                                          01870002
      GO TO 40080                                                       01880002
30080 IVDELE=IVDELE+1                                                   01890002
      WRITE (I02,80003) IVTNUM                                          01900002
      IF (ICZERO) 40080,91,40080                                        01910002
40080 IF (IVON01-8) 20080,10080,20080                                   01920002
10080 IVPASS=IVPASS+1                                                   01930002
      WRITE (I02,80001) IVTNUM                                          01940002
      GO TO 91                                                          01950002
20080 IVFAIL=IVFAIL+1                                                   01960002
      IVCOMP=IVON01                                                     01970002
      IVCORR=8                                                          01980002
      WRITE (I02,80004) IVTNUM,IVCOMP,IVCORR                            01990002
   91 CONTINUE                                                          02000002
      IVTNUM=9                                                          02010002
C                                                                       02020002
C      ****  TEST 009  ****                                             02030002
C     TEST 009 - WRITE STATEMENT IN A COMMENT LINE                      02040002
C                                                                       02050002
      IF (ICZERO) 30090,90,30090                                        02060002
   90 CONTINUE                                                          02070002
      IVON01=200                                                        02080002
C  92 WRITE (I02,80002)  IVTNUM                                         02090002
      IVON01=9                                                          02100002
      GO TO 40090                                                       02110002
30090 IVDELE=IVDELE+1                                                   02120002
      WRITE (I02,80003) IVTNUM                                          02130002
      IF (ICZERO) 40090,101,40090                                       02140002
40090 IF (IVON01-9) 20090,10090,20090                                   02150002
10090 IVPASS=IVPASS+1                                                   02160002
      WRITE (I02,80001) IVTNUM                                          02170002
      GO TO 101                                                         02180002
20090 IVFAIL=IVFAIL+1                                                   02190002
      IVCOMP=IVON01                                                     02200002
      IVCORR=9                                                          02210002
      WRITE (I02,80004) IVTNUM,IVCOMP,IVCORR                            02220002
  101 IVTNUM=10                                                         02230002
C                                                                       02240002
C      ****  TEST 010  ****                                             02250002
C     TEST 010 - STATEMENT LABEL IN COMMENT LINE                        02260002
C                                                                       02270002
      IF (ICZERO) 30100,100,30100                                       02280002
  100 CONTINUE                                                          02290002
      GO TO 102                                                         02300002
C 102 WRITE (I02,80002)                                                 02310002
C     GO TO 111                                                         02320002
  102 IVON01=10                                                         02330002
      GO TO 40100                                                       02340002
30100 IVDELE=IVDELE+1                                                   02350002
      WRITE (I02,80003) IVTNUM                                          02360002
      IF (ICZERO) 40100,111,40100                                       02370002
40100 IF (IVON01-10) 20100,10100,20100                                  02380002
10100 IVPASS=IVPASS+1                                                   02390002
      WRITE (I02,80001) IVTNUM                                          02400002
      GO TO 111                                                         02410002
20100 IVFAIL=IVFAIL+1                                                   02420002
      IVCOMP=IVON01                                                     02430002
      IVCORR=10                                                         02440002
      WRITE (I02,80004) IVTNUM,IVCOMP,IVCORR                            02450002
  111 CONTINUE                                                          02460002
      IVTNUM=11                                                         02470002
C                                                                       02480002
C      ****  TEST 011  ****                                             02490002
C     TEST 011 - CONTINUE IN COMMENT LINE                               02500002
C                FOLLOWED BY INTEGER ASSIGNMENT STATEMENT IN COMMENT    02510002
C                                                                       02520002
      IF (ICZERO) 30110,110,30110                                       02530002
  110 IVON01=11                                                         02540002
C     CONTINUE                                                          02550002
C     IVON01=7000                                                       02560002
      GO TO 40110                                                       02570002
30110 IVDELE=IVDELE+1                                                   02580002
      WRITE (I02,80003) IVTNUM                                          02590002
      IF (ICZERO) 40110,121,40110                                       02600002
40110 IF (IVON01 -11) 20110,10110,20110                                 02610002
10110 IVPASS=IVPASS+1                                                   02620002
      WRITE (I02,80001) IVTNUM                                          02630002
      GO TO 121                                                         02640002
20110 IVFAIL=IVFAIL+1                                                   02650002
      IVCOMP=IVON01                                                     02660002
      IVCORR=11                                                         02670002
      WRITE (I02,80004) IVTNUM,IVCOMP,IVCORR                            02680002
  121 CONTINUE                                                          02690002
      IVTNUM=12                                                         02700002
C                                                                       02710002
C      ****  TEST 012  ****                                             02720002
C     TEST 012 - INTEGER ASSIGNMENT STATEMENT IN COMMENT LINE           02730002
C                                                                       02740002
      IF (ICZERO) 30120,120,30120                                       02750002
  120 CONTINUE                                                          02760002
      IVON01=12                                                         02770002
C     IVON01=IVON01+1                                                   02780002
      GO TO 40120                                                       02790002
30120 IVDELE=IVDELE+1                                                   02800002
      WRITE (I02,80003) IVTNUM                                          02810002
      IF (ICZERO) 40120,99999,40120                                     02820002
40120 IF (IVON01 - 12) 20120,10120,20120                                02830002
10120 IVPASS=IVPASS+1                                                   02840002
      WRITE (I02,80001) IVTNUM                                          02850002
      GO TO 99999                                                       02860002
20120 IVFAIL=IVFAIL+1                                                   02870002
      IVCOMP=IVON01                                                     02880002
      IVCORR=12                                                         02890002
      WRITE (I02,80004) IVTNUM,IVCOMP,IVCORR                            02900002
C                                                                       02910002
C     WRITE PAGE FOOTINGS AND RUN SUMMARIES                             02920002
99999 CONTINUE                                                          02930002
      WRITE (I02,90002)                                                 02940002
      WRITE (I02,90006)                                                 02950002
      WRITE (I02,90002)                                                 02960002
      WRITE (I02,90002)                                                 02970002
      WRITE (I02,90007)                                                 02980002
      WRITE (I02,90002)                                                 02990002
      WRITE (I02,90008)  IVFAIL                                         03000002
      WRITE (I02,90009) IVPASS                                          03010002
      WRITE (I02,90010) IVDELE                                          03020002
C                                                                       03030002
C                                                                       03040002
C     TERMINATE ROUTINE EXECUTION                                       03050002
      STOP                                                              03060002
C                                                                       03070002
C     FORMAT STATEMENTS FOR PAGE HEADERS                                03080002
90000 FORMAT ("1")                                                      03090002
90002 FORMAT (" ")                                                      03100002
90001 FORMAT (" ",10X,"FORTRAN COMPILER VALIDATION SYSTEM" )            03110002
90003 FORMAT (" ",21X,"VERSION 2.1" )                                   03120002
90004 FORMAT (" ",10X,"FOR OFFICIAL USE ONLY - COPYRIGHT 1978" )        03130002
90005 FORMAT (" ",5X,"TEST",5X,"PASS/FAIL", 5X,"COMPUTED",8X,"CORRECT") 03140002
90006 FORMAT (" ",5X,"----------------------------------------------" ) 03150002
90011 FORMAT (" ",18X,"SUBSET LEVEL TEST" )                             03160002
C                                                                       03170002
C     FORMAT STATEMENTS FOR RUN SUMMARIES                               03180002
90008 FORMAT (" ",15X,I5," ERRORS ENCOUNTERED" )                        03190002
90009 FORMAT (" ",15X,I5," TESTS PASSED" )                              03200002
90010 FORMAT (" ",15X,I5," TESTS DELETED" )                             03210002
C                                                                       03220002
C     FORMAT STATEMENTS FOR TEST RESULTS                                03230002
80001 FORMAT (" ",4X,I5,7X,"PASS")                                      03240002
80002 FORMAT (" ",4X,I5,7X,"FAIL")                                      03250002
80003 FORMAT (" ",4X,I5,7X,"DELETED")                                   03260002
80004 FORMAT (" ",4X,I5,7X,"FAIL",10X,I6,9X,I6)                         03270002
80005 FORMAT (" ",4X,I5,7X,"FAIL",4X,E12.5,3X,E12.5)                    03280002
C                                                                       03290002
90007 FORMAT (" ",20X,"END OF PROGRAM FM002" )                          03300002
C     COMMENT LINE BEFORE END STATEMENT                                 03310002
      END                                                               03320002

max_stars_repo_name: MrSidims/llvm-test-suite

max_issues_repo_name: MrSidims/llvm-test-suite

max_forks_repo_name: MrSidims/llvm-test-suite


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


text:
!> @file
!! Define the concept of memory buffer, useful for DMA and device memory handling
!! @author
!!    Copyright (C) 2014-2015 BigDFT group
!!    This file is distributed under the terms of the
!!    GNU General Public License, see ~/COPYING file
!!    or http://www.gnu.org/copyleft/gpl.txt .
!!    For the list of contributors, see ~/AUTHORS
module f_buffers
  use iso_c_binding
  use dictionaries

  implicit none

  character(len=*), parameter :: DATATYPE_KEY='datatype'
  character(len=*), parameter :: METHOD_KEY='method'

  character(len=*), parameter :: F_PTR_UC='F_PTR'
  character(len=*), parameter :: F_PTR_LC='f_ptr'
  character(len=*), parameter :: C_PTR_UC='C_PTR'
  character(len=*), parameter :: C_PTR_LC='c_ptr'
  character(len=*), parameter :: CUDA_PTR_UC='CUDA_PTR'
  character(len=*), parameter :: CUDA_PTR_LC='cuda_ptr'
  character(len=*), parameter :: OCL_PTR_UC='OCL_PTR'
  character(len=*), parameter :: OCL_PTR_LC='ocl_ptr'
  character(len=*), parameter :: DATATYPE_INT_LC='integer'
  character(len=*), parameter :: DATATYPE_INT_UC='INTEGER'
  character(len=*), parameter :: DATATYPE_DOUBLE_LC='double'
  character(len=*), parameter :: DATATYPE_DOUBLE_UC='DOUBLE'

  integer, parameter :: HOST=0
  integer, parameter :: CUDA=1
  integer, parameter :: OCL=2

  integer, parameter :: GPU_INTEGER=1
  integer, parameter :: GPU_SIMPLE=-1
  integer, parameter :: GPU_DOUBLE=2

  type, public :: f_buffer
     !> information about the buffer, extensible metadata
     type(dictionary), pointer :: info
     !intrinsic pointers
     integer(f_integer), dimension(:), pointer :: f_ptr_i
     real(f_double), dimension(:), pointer :: f_ptr_d
     type(c_ptr) :: ptr !< points to GPU data of C_PTR
  end type f_buffer

contains

  pure subroutine nullify_f_buffer(g)
    implicit none
    type(f_buffer), intent(out) :: g
    nullify(g%info)
    nullify(g%f_ptr)
    g%ptr=C_NULL_PTR
  end subroutine nullify_GPU_ptr

  pure function sizeof(g) result(b)
    implicit none
    type(f_buffer), intent(in) :: g
    !local variables
    character(len=20) :: datatype

    call f_zero(datatype)
    datatype=g%info .get. DATATYPE_KEY
    select case(trim(g%datatype))
    case(DATATYPE_INT_LC,DATATYPE_INT_UC)
       b=4
    case(DATATYPE_DOUBLE_LC,DATATYPE_DOUBLE_UC)
       b=8
    case default
       b=0
    end select

  end function sizeof

  !>low level allocation of the buffer pointers
  subroutine allocate_f_buf(buf,size,datatype,method,ierror)
    implicit none
    type(f_buffer), intent(in) :: buf
    integer, intent(in) :: size
    character(len=*), intent(in) :: datatype,method
    integer, intent(out) :: ierror
    integer(f_long) :: size_t

    ierror=-1
    !initialize the buffer metadata
    if (associated(buf%info)) &
         call f_err_throw('Attempting to reallocate buffer, memory leak')
    size_t=size*sizeof(buf)
    select case(trim(method))
    case(F_PTR_UC,F_PTR_LC)
       select case(trim(datatype))
       case(DATATYPE_INT_LC,DATATYPE_INT_UC)
          allocate(buf%f_ptr_i(size),stat=ierror)
       case(DATATYPE_DOUBLE_LC,DATATYPE_DOUBLE_UC)
          allocate(buf%f_ptr_d(size),stat=ierror)
       case default
          call err()
       end select
    case(C_PTR_UC,C_PTR_LC)
       select case(trim(datatype))
          !allocation for c_pointer, might be wrapped in C
       case default
          call err()
       end select
    case(CUDA_PTR_UC,CUDA_PTR_LC)
       select case(trim(datatype))
       case(DATATYPE_DOUBLE_LC,DATATYPE_DOUBLE_UC)
          call cudamalloc(size,buf%ptr,ierror)
       case default
          call err()
       end select
    case(OCL_PTR_UC,OCL_PTR_LC)
       select case(trim(datatype))
       !case(DATATYPE_DOUBLE_LC,DATATYPE_DOUBLE_UC)
       case default
          call err()
       end select
    case default
       call f_err_throw('Method type "'//trim(method)//&
            '"unknown for f_buffer')
    end select

   buf%info => dict_new(DATATYPE_KEY .is. datatype,&
        METHOD_KEY .is. method,&
        SIZEOF_KEY .is. size_t)

   contains
     subroutine err()
          call f_err_throw('Datatype '//trim(datatype)//&
               'not supported for method '//trim(method))
     end subroutine err

  end subroutine allocate_f_buf

  !>low level deallocation of the buffer pointers
  subroutine deallocate_f_buf(buf,ierror)
    implicit none
    type(f_buffer), intent(in) :: buf
    integer, intent(out) :: ierror
    !local variables
    character(len=32) :: datatype,method

    ierror=-1
    call f_zero(datatype)
    call f_zero(method)

    !initialize the buffer metadata
    if (.not. associated(buf%info)) &
         call f_err_throw('Attempting to deallocate free buffer, double free')
    datatype=buf%info .get. DATATYPE_KEY
    method=buf%info .get. METHOD_KEY
    select case(trim(method))
    case(F_PTR_UC,F_PTR_LC)
       select case(trim(datatype))
       case(DATATYPE_INT_LC,DATATYPE_INT_UC)
          deallocate(buf%f_ptr_i,stat=ierror)
       case(DATATYPE_DOUBLE_LC,DATATYPE_DOUBLE_UC)
          deallocate(buf%f_ptr_d,stat=ierror)
       case default
          call err()
       end select
    case(C_PTR_UC,C_PTR_LC)
       select case(trim(datatype))
          !deallocation for c_pointer, might be wrapped in C
       case default
          call err()
       end select
    case(CUDA_PTR_UC,CUDA_PTR_LC)
       select case(trim(datatype))
       case(DATATYPE_DOUBLE_LC,DATATYPE_DOUBLE_UC)
          call cudafree(buf%ptr)
          ierror=0 !we should wrap the cuda errors
       case default
          call err()
       end select
    case(OCL_PTR_UC,OCL_PTR_LC)
       select case(trim(datatype))
          !case(DATATYPE_DOUBLE_LC,DATATYPE_DOUBLE_UC)
       case default
          call err()
       end select
    case default
       call f_err_throw('Method type "'//trim(method)//&
            '"unknown for f_buffer')
    end select

    if (ierror==0) then
       call dict_free(buf%info)
       call nullify_f_buffer(buf)
    end if

  contains
    subroutine err()
      call f_err_throw('Datatype '//trim(datatype)//&
           'not supported for method '//trim(method))
    end subroutine err

  end subroutine deallocate_f_buf

  subroutine zero_f_buf(buf)
    implicit none
    type(f_buffer), intent(in) :: buf
    !local variables
    integer :: ierror,size
    integer(f_long) :: size_t
    character(len=32) :: datatype,method

    call f_zero(datatype)
    call f_zero(method)

    !initialize the buffer metadata
    if (.not. associated(buf%info)) &
         call f_err_throw('Attempting to deallocate free buffer, double free')
    datatype=buf%info .get. DATATYPE_KEY
    method=buf%info .get. METHOD_KEY
    select case(trim(method))
    case(F_PTR_UC,F_PTR_LC)
       select case(trim(datatype))
       case(DATATYPE_INT_LC,DATATYPE_INT_UC)
          call f_zero(buf%f_ptr_i)
       case(DATATYPE_DOUBLE_LC,DATATYPE_DOUBLE_UC)
          call f_zero(buf%f_ptr_d)
       case default
          call err()
       end select
    case(C_PTR_UC,C_PTR_LC)
       select case(trim(datatype))
          !deallocation for c_pointer, might be wrapped in C
       case default
          call err()
       end select
    case(CUDA_PTR_UC,CUDA_PTR_LC)
       select case(trim(datatype))
       case(DATATYPE_DOUBLE_LC,DATATYPE_DOUBLE_UC)
          !memset to be simplified
          size_t=buf%info//SIZEOF_KEY
          size=int(size_t/sizeof(buf))
          call cudamemset(buf%ptr, 0, size,ierror)
          if (ierror /=0) call f_err_throw('Error in zero_f_buf')
       case default
          call err()
       end select
    case(OCL_PTR_UC,OCL_PTR_LC)
       select case(trim(datatype))
          !case(DATATYPE_DOUBLE_LC,DATATYPE_DOUBLE_UC)
       case default
          call err()
       end select
    case default
       call f_err_throw('Method type "'//trim(method)//&
            '" unknown for f_buffer')
    end select

  contains
    subroutine err()
      call f_err_throw('Datatype '//trim(datatype)//&
           'not supported for method '//trim(method))
    end subroutine err

  end subroutine zero_f_buf

  subroutine deppcopy_f_buf(buf,src_add)
    implicit none
    type(f_buffer), intent(in) :: buf
    integer(f_long), intent(in) :: src_add
    !local variables
    integer :: ierror,size
    integer(f_long) :: size_t
    character(len=32) :: datatype,method

    call f_zero(datatype)
    call f_zero(method)

    !initialize the buffer metadata
    if (.not. associated(buf%info)) &
         call f_err_throw('Attempting to copy into free buffer')
    datatype=buf%info .get. DATATYPE_KEY
    method=buf%info .get. METHOD_KEY
    select case(trim(method))
    case(F_PTR_UC,F_PTR_LC)
       select case(trim(datatype))
       case default
          call err()
       end select
    case(C_PTR_UC,C_PTR_LC)
       select case(trim(datatype))
          !deallocation for c_pointer, might be wrapped in C
       case default
          call err()
       end select
    case(CUDA_PTR_UC,CUDA_PTR_LC)
       select case(trim(datatype))
       case(DATATYPE_DOUBLE_LC,DATATYPE_DOUBLE_UC)
          !memset to be simplified
          size_t=buf%info//SIZEOF_KEY
          call copy_buffer_to_gpu_fromadd(array%sizeof,m%srcdata_add,array%ptr,ierror)
          if (ierror /=0) call f_err_throw('Error in deepcopy_f_buf')
       case default
          call err()
       end select
    case(OCL_PTR_UC,OCL_PTR_LC)
       select case(trim(datatype))
          !case(DATATYPE_DOUBLE_LC,DATATYPE_DOUBLE_UC)
       case default
          call err()
       end select
    case default
       call f_err_throw('Method type "'//trim(method)//&
            '" unknown for f_buffer')
    end select

  contains
    subroutine err()
      call f_err_throw('Datatype '//trim(datatype)//&
           'not supported for method '//trim(method))
    end subroutine err

  end subroutine deppcopy_f_buf

end module f_buffers

max_stars_repo_name: adegomme/aiida-bigdft-plugin