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 chkerr (routine, caller, ierr)
C=======================================================================
C     Modified 9/13/95 for EXODUSIIV2 API calls

C     This subroutine should be called after an EXODUSIIV2 subroutine has
C     been invoked.  The arguments of this subroutine are as follows:
C     routine - IN - The exodusIIv2 subroutine
C     caller  - IN - The subroutine invoking the exodusII call
C     ierr    - IN - The error code returned from the exodusII call

      include 'exodusII.inc'

      character*6 routine
      CHARACTER*8 caller
      character*(512) string, path, msg
      integer ierr

C     No error occurred
      if (ierr .eq. EXOK) RETURN

      write (path, '(A,A2,A)') CALLER(:LENSTR(CALLER)), '->',
     &       ROUTINE(:LENSTR(ROUTINE))
      lp = lenstr(path)

      if (ierr .eq. EXWARN) then
         write (string, '(A,A)')'ExodusII V2 WARNING in ', path(:lp)
         call prterr('WARNING', string)
         RETURN
      else if (ierr .lt. EXOK) then
         write (string, '(A)')'ExodusII V2 ERROR'
         call prterr('ERROR', string)
      end if

      if (ierr .eq. EXFATL) then
         write (msg, '(A,A)')
     &   'A Fatal error occurred in ', path(:lp)
      else if (ierr .eq. EXMEMF) then
         write (msg, '(A,A)')
     &   'Memory allocation failure flag in ', path(:lp)
      else if (ierr .eq. EXBFMD) then
         write (msg, '(A,A)')
     &   'Bad file mode in ', path(:lp)
      else if (ierr .eq. EXBFID) then
         write (msg, '(A,A)')
     &   'BAD file ID in ', path(:lp)
      else if (ierr .eq. EXBTID) then
         write (msg, '(A,A)')
     &   'Property table lookup failed in ', path(:lp)
      else if (ierr .eq. EXBPRM) then
         write (msg, '(A,A)')
     &   'Bad parameter passed in ', path(:lp)
      else
         write (msg, '(A,A,A,I4)')
     &   'Unknown Error in ', path(:lp), ': IERR =  ',ierr
      end if

      call prterr ('ERROR', msg)

      return
      end

max_stars_repo_name: jschueller/seacas

max_issues_repo_name: jschueller/seacas

max_forks_repo_name: jschueller/seacas


text:
      subroutine cortab(binom,dfac,eps,flmtx,hpt,hwt,lmf,lml,lmx,lmy,
     &  lmz,lmax,lmn1u,lproju,mc,mr,ndfac,zlm)
c     # tables for core potential and spin-orbit integrals.
      implicit real*8 (a-h,o-z)
      parameter (a0=0.0d0, a1s2=0.5d0, a1=1.0d0, a2=2.0d0, a3=3.0d0)
      dimension binom(*),dfac(*),flmtx(3,*),hpt(*),hwt(*),lmf(*),
     &  lml(*),lmx(*),lmy(*),lmz(*),mc(3,*),mr(3,*),zlm(*)
c
c     # compute gauss-hermite points and weights for c, z integrals.
      igh =1
      nn = 5
      do 120 i = 1, 3
        call hermit(nn,hpt(igh),hwt(igh),eps)
        igh = igh + nn
        nn = 2*nn
  120 continue
c     # compute double factorials.
      dfac(1)=a1
      dfac(2)=a1
      fi=a0
      do 130 i=1,ndfac-2
        fi=fi+a1
        dfac(i+2)=fi * dfac(i)
  130 continue
c     # compute binomial coefficients.
      inew=1
      binom(1)=a1
      do 150 j=1,lmn1u-1
        inew=inew+1
        binom(inew)=a1
        do 140 i=1,j-1
          inew=inew+1
          binom(inew)=((j-i+1)*binom(inew-1))/(i)
  140   continue
        inew=inew+1
        binom(inew)=a1
  150 continue
c     # compute tables by recursion for real spherical harmonics.  they
c     # are indexed by l, m and sigma.  the sequence number of the
c     # harmonic with quantum numbers l, m and sigma is given by
c     #            l**2+2*m+1-sigma
c     # lmf(index) and lml(index) hold the positions of the first and
c     # last terms of the harmonic in the lmx, lmy, lmz, and zlm arrays.
c     # the harmonics with angular momentum l are generated from those
c     # with angular momenta l-1 and l-2.
c     # for m = 0,1,2,...,l-1, the recursion relation
c     z*Z(l-1,m,s) = sqrt(((l-m)*(l+m))/((2*l-1)*(2*l+1)))*Z(l,m,s)+
c                  sqrt(((l+m-1)*(l-m-1))/((2*l-3)*(2*l-1)))*Z(l-2,m,s)
c     # is used.
c     # for m = l, the recursion relation
c     x*Z(l-1,l-1,s)+(-1)**(1-s)*y*Z(l-1,l-1,1-s) =
c                  sqrt((2*l))/((2*l+1)))*Z(l,l,s)
c     # is used.
c     # l=0
      lmf(1) = 1
      lml(1) = 1
      lmx(1) = 0
      lmy(1) = 0
      lmz(1) = 0
      zlm(1) = a1
c     # l=1
      lmf(2) = 2
      lml(2) = 2
      lmx(2) = 0
      lmy(2) = 0
      lmz(2) = 1
      zlm(2) = sqrt(a3)
      lmf(3) = 3
      lml(3) = 3
      lmx(3) = 0
      lmy(3) = 1
      lmz(3) = 0
      zlm(3) = zlm(2)
      lmf(4) = 4
      lml(4) = 4
      lmx(4) = 1
      lmy(4) = 0
      lmz(4) = 0
      zlm(4) = zlm(2)
      nterm=4
      do 270 lang=2,lmax
        do 240 mang=0,lang-1
          anum = ((2*lang-1)*(2*lang+1))
          aden = ((lang-mang)*(lang+mang))
          coef1 = sqrt(anum/aden)
          anum = ((lang+mang-1)*(lang-mang-1)*(2*lang+1))
          aden = (2*lang-3)*aden
          coef2 = sqrt(anum/aden)
          nsigma=min(1,mang)
          do 230 isigma=nsigma,0,-1
            indexh=lang**2+2*mang+1-isigma
            lone=lang-1
            ltwo=lang-2
            ione=lone**2+2*mang+1-isigma
            itwo=ltwo**2+2*mang+1-isigma
            lmf(indexh)=lml(indexh-1)+1
            lml(indexh)=lml(indexh-1)
            nxy=(mang-isigma+2)/2
            iu=lmf(ione)+nxy-1
            do 200 i=lmf(ione),iu
              lml(indexh)=lml(indexh)+1
              j=lml(indexh)
              lmx(j)=lmx(i)
              lmy(j)=lmy(i)
              lmz(j)=lmz(i)+1
              zlm(j)=zlm(i)*coef1
              nterm=nterm+1
  200       end do
            if(ltwo.ge.mang) then
              il=iu+1
              do 210 i=il,lml(ione)
                lml(indexh)=lml(indexh)+1
                j=lml(indexh)
                k=lmf(itwo)+i-il
                lmx(j)=lmx(k)
                lmy(j)=lmy(k)
                lmz(j)=lmz(k)
                zlm(j)=zlm(i)*coef1-zlm(k)*coef2
                nterm=nterm+1
  210         enddo
              il=lml(itwo)-nxy+1
              if(mod(lang-mang,2).eq.0) then
                do 220 i=il,lml(itwo)
                  lml(indexh)=lml(indexh)+1
                  j=lml(indexh)
                  lmx(j)=lmx(i)
                  lmy(j)=lmy(i)
                  lmz(j)=lmz(i)
                  zlm(j)=-zlm(i)*coef2
                  nterm=nterm+1
  220           end do
              endif
            endif
  230     end do
  240   end do
        anum = (2*lang+1)
        aden = (2*lang)
        coef = sqrt(anum/aden)
        mang=lang
        isigma=1
        indexh=lang**2+2*mang+1-isigma
        lmf(indexh)=lml(indexh-1)+1
        lml(indexh)=lml(indexh-1)
c       # isig:  index of the harmonic (l-1),(m-1),sigma
c       # isigm: index of the harmonic (l-1),(m-1),(1-sigma)
        isig=(lang-1)**2+2*(mang-1)+1-isigma
        isigm=(lang-1)**2+2*(mang-1)+isigma
        k=lmf(isigm)
        do 250 i=lmf(isig),lml(isig)
          lml(indexh)=lml(indexh)+1
          j=lml(indexh)
          lmx(j)=lmx(i)+1
          lmy(j)=lmy(i)
          lmz(j)=lmz(i)
          zlm(j)=(zlm(i)+zlm(k))*coef
          k=k+1
          nterm=nterm+1
  250   enddo
        if(mod(mang,2).eq.1) then
          lml(indexh)=lml(indexh)+1
          j=lml(indexh)
          lmx(j)=lmx(k)
          lmy(j)=lmy(k)+1
          lmz(j)=lmz(k)
          zlm(j)=zlm(k)*coef
          nterm=nterm+1
        endif
        isigma=0
        indexh=lang**2+2*mang+1-isigma
c       # isig:  index of the harmonic (l-1),(m-1),sigma
c       # isigm: index of the harmonuc (l-1),(m-1),(1-sigma)
        isig=(lang-1)**2+2*(mang-1)+1-isigma
        isigm=(lang-1)**2+2*(mang-1)+isigma
        lmf(indexh)=lml(indexh-1)+1
        lml(indexh)=lmf(indexh)
        j=lml(indexh)
        i=lmf(isig)
        lmx(j)=lmx(i)+1
        lmy(j)=lmy(i)
        lmz(j)=lmz(i)
        zlm(j)=zlm(i)*coef
        nterm=nterm+1
        k=lmf(isigm)
        do 260 i=lmf(isig)+1,lml(isig)
          lml(indexh)=lml(indexh)+1
          j=lml(indexh)
          lmx(j)=lmx(i)+1
          lmy(j)=lmy(i)
          lmz(j)=lmz(i)
          zlm(j)=(zlm(i)-zlm(k))*coef
          k=k+1
          nterm=nterm+1
  260   enddo
        if(mod(mang,2).eq.0) then
          lml(indexh)=lml(indexh)+1
          j=lml(indexh)
          k=lml(isigm)
          lmx(j)=lmx(k)
          lmy(j)=lmy(k)+1
          lmz(j)=lmz(k)
          zlm(j)=-zlm(k)*coef
          nterm=nterm+1
        endif
  270 end do
      ixy = 0
      iz = 0
      do 300 lang=1,lproju
        do 290 mang=0,lang-1
          nsigma=min(1,mang)
          ndelta=max(0,1-mang)
          anum = ((lang-mang)*(lang+mang+1))
          aden = (2*(2-ndelta))
          coef=sqrt(anum/aden)
          do 280 isigma=nsigma,0,-1
            isign=2*isigma-1
            ixy = ixy+1
            flmtx(1,ixy) = (isign)*coef
            flmtx(2,ixy) = coef
            if(mang.ne.0) then
              iz=iz+1
              flmtx(3,iz) = -(mang*isigma)
            endif
  280     enddo
  290   enddo
        iz=iz+1
        flmtx(3,iz) = -(lang)
  300 enddo
c     # column and row indices for angular momentum matrix elements.
      iadd = 1
      do 310 i=1,2*lproju-1
        mc(1,i) = i
        mc(2,i) = i
        mc(3,i) = i+1
        mr(1,i) = i+iadd
        mr(2,i) = i+2
        mr(3,i) = i+2
        iadd = 4-iadd
  310 continue
      return
      end

ext: f

max_stars_repo_name: MOLFDIR/MOLFDIR

max_issues_repo_name: yingxingcheng/MOLFDIR

max_forks_repo_name: yingxingcheng/MOLFDIR


text:
! ###################################################################
! Copyright (c) 2013-2015, Marc De Graef/Carnegie Mellon University
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification, are
! permitted provided that the following conditions are met:
!
!     - Redistributions of source code must retain the above copyright notice, this list
!        of conditions and the following disclaimer.
!     - Redistributions in binary form must reproduce the above copyright notice, this
!        list of conditions and the following disclaimer in the documentation and/or
!        other materials provided with the distribution.
!     - Neither the names of Marc De Graef, Carnegie Mellon University nor the names
!        of its contributors may be used to endorse or promote products derived from
!        this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
! ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
! LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
! USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
! ###################################################################

!--------------------------------------------------------------------------
! EMsoft:EMOrientationSimilarity.f90
!--------------------------------------------------------------------------
!
! PROGRAM: EMOrientationSimilarity
!
!> @author Marc De Graef, Carnegie Mellon University
!
!> @brief create a tiff file with an OSM map
!
!> @date 07/29/16 MDG 1.0 original
!--------------------------------------------------------------------------
program EMOrientationSimilarity

use local
use typedefs
use NameListTypedefs
use NameListHandlers
use files
use constants
use dictmod
use io
use error
use ECPmod
use EBSDiomod
use EBSDmod
use EBSDDImod
use HDF5
use HDFsupport
use TIFF_f90
use stringconstants

IMPLICIT NONE

character(fnlen)                        :: nmldeffile, progname, progdesc
type(OrientationSimilarityNameListType) :: enl

logical                                 :: stat, readonly, noindex
integer(kind=irg)                       :: hdferr, nlines, FZcnt, Nexp, nnm, nnk, Pmdims, i, j, k, olabel, Nd, Ne, ipar(10), &
                                           ipar2(6), pgnum, ipat, ipf_wd, ipf_ht, idims2(2)
character(fnlen)                        :: groupname, dataset, dpfile, energyfile, masterfile, efile, fname
integer(HSIZE_T)                        :: dims2(2)

integer(kind=irg),allocatable           :: tmi(:,:), tmitmp(:,:)
real(kind=sgl),allocatable              :: osm(:,:)

type(HDFobjectStackType),pointer        :: HDF_head

nullify(HDF_head)

nmldeffile = 'EMOrientationSimilarity.nml'
progname = 'EMOrientationSimilarity.f90'
progdesc = 'Generate an orientation similarity map'

! print some information
call EMsoft(progname, progdesc)

! deal with the command line arguments, if any
call Interpret_Program_Arguments(nmldeffile,1,(/ 83 /), progname)

! deal with the namelist stuff
call GetOrientationSimilarityNameList(nmldeffile,enl)

!====================================
! read the relevant fields from the dot product HDF5 file

! open the fortran HDF interface
call h5open_EMsoft(hdferr)

dpfile = trim(EMsoft_getEMdatapathname())//trim(enl%dotproductfile)
dpfile = EMsoft_toNativePath(dpfile)

! is this a proper HDF5 file ?
call h5fis_hdf5_f(trim(dpfile), stat, hdferr)

if (stat) then
! open the dot product file
  readonly = .TRUE.
  hdferr =  HDF_openFile(dpfile, HDF_head, readonly)

! get the energyfile and masterfile parameters from NMLParameters
groupname = SC_NMLparameters
    hdferr = HDF_openGroup(groupname, HDF_head)
groupname = SC_EBSDIndexingNameListType
    hdferr = HDF_openGroup(groupname, HDF_head)

dataset = SC_nnk
    call HDF_readDatasetInteger(dataset, HDF_head, hdferr, nnk)

dataset = SC_ipfwd
    call HDF_readDatasetInteger(dataset, HDF_head, hdferr, ipf_wd)
dataset = SC_ipfht
    call HDF_readDatasetInteger(dataset, HDF_head, hdferr, ipf_ht)

! and close the NMLparameters group
    call HDF_pop(HDF_head)
    call HDF_pop(HDF_head)

! open the Scan 1/EBSD/Data group
    groupname = SC_Scan1
    hdferr = HDF_openGroup(groupname, HDF_head)
groupname = SC_EBSD
    hdferr = HDF_openGroup(groupname, HDF_head)
groupname = SC_Data
    hdferr = HDF_openGroup(groupname, HDF_head)

! integers
dataset = SC_NumExptPatterns
    call HDF_readDatasetInteger(dataset, HDF_head, hdferr, Nexp)

! arrays
dataset = SC_TopMatchIndices
    call HDF_readDatasetIntegerArray2D(dataset, dims2, HDF_head, hdferr, tmitmp)
    allocate(tmi(nnk,Nexp))
    do i=1,Nexp
      tmi(1:nnk,i) = tmitmp(1:nnk,i)
    end do
    idims2 = (/ nnk, Nexp /)
    deallocate(tmitmp)
  call HDF_pop(HDF_head,.TRUE.)

! close the fortran HDF interface
  call h5close_EMsoft(hdferr)

  call Message('dot product HDF5 file read')
end if

! and next we compute the orientation similarity map (osm)

allocate(osm(ipf_wd,ipf_ht))
call EBSDgetOrientationSimilarityMap(idims2, tmi, enl%nmuse, ipf_wd, ipf_ht, osm)

osm = osm/maxval(osm)
osm = osm*255

TIFF_filename = trim(EMsoft_getEMdatapathname())//trim(enl%osmtiff)
TIFF_filename = EMsoft_toNativePath(TIFF_filename)

TIFF_nx = ipf_wd
TIFF_ny = ipf_ht
! allocate memory for image
allocate(TIFF_image(0:TIFF_nx-1,0:TIFF_ny-1))
! fill the image with whatever data you have (between 0 and 255)
 do i=0,TIFF_nx-1
  do j=0,TIFF_ny-1
   TIFF_image(i,j) = osm(i+1,ipf_ht-j)
  end do
 end do
! create the file
 call TIFF_Write_File

call Message('OSM map written to '//trim(TIFF_filename))

end program EMOrientationSimilarity

max_stars_repo_name: imikejackson/EMsoft

max_issues_repo_name: imikejackson/EMsoft

max_forks_repo_name: imikejackson/EMsoft


text:
!> @addtogroup p4a_accel_stubs

!> @{

!> @defgroup p4a_accel_Fortran_stubs Equivalent stubs in Fortran of Par4All runtime to have PIPS analyzes happy

!> @{

!>  Stub for copying memory from the host to the hardware accelerator.
!>
!>  Since it is a stub so that PIPS can understand it, use simple
!>  implementation with standard memory copy operations
!>
!>  Do not change the place of the pointers in the API. The host address
!>  is always in the first position...
!>
!>  @param[in] host_add is the address of a source zone in the host memory
!>
!>  @param[out] accel_add is the address of a destination zone in the
!>  accelerator memory
!>
!>  @param[in] size is the size in bytes of the memory zone to copy
	subroutine P4A_COPY_TO_ACCEL(host_add, accel_add, size)
	integer size
	character host_add(size)
	character accel_add(size)
	integer i

	do i = 1,size
	   accel_add(i) = host_add(i)
	end do
	end

!>  Stub for copying memory from the hardware accelerator to the host.
!>
!>  Do not change the place of the pointers in the API. The host address
!>  is always in the first position...
!>
!>  @param[out] host_add is the address of a destination zone in the
!>  host memory
!>
!>  @param[in] accel_add is the address of a source zone in the
!>  accelerator memory
!>
!>  @param[in] size is the size in bytes of the memory zone to copy
	subroutine P4A_COPY_FROM_ACCEL(host_add, accel_add, size)
	integer size
	character host_add(size)
	character accel_add(size)
	integer i

	do i = 1,size
	   host_add(i) = accel_add(i)
	end do
	end

!> Stub for copying memory from the host to the hardware accelerator.
!>
!> Since it is a stub so that PIPS can understand it, use simple
!> implementation with standard memory copy operations
!>
!>  Do not change the place of the pointers in the API. The host address
!>  is always in the first position...
!>
!>  This function could be quite simpler but is designed by symmetry with
!>  other functions.
!>
!>  @param[in] elem_size is the size of one element of the array in
!>  byte
!>
!>  @param[in] d1_size is the number of elements in the array.
!>
!>  @param[in] d1_size is the number of elements in the array. It is not
!>  used but here for symmetry with functions of higher dimensionality
!>
!>  @param[in] d1_block_size is the number of element to transfer
!>
!>  @param[in] d1_offset is the element order to start the transfer to
!>
!>  @param[out] host_add point to the array on the host to write into
!>
!>  @param[in] accel_add refer to the compact memory area to read
!>  data. In the general case, accel_add may be seen as a unique idea (FIFO)
!>  and not some address in some memory space.

	subroutine P4A_COPY_FROM_ACCEL_1D (elem_size, d1_size,
     &  d1_block_size, d1_offset, host_add, accel_add)

	integer d1_size
	integer elem_size
	integer d1_block_size
	integer d1_offset
	character host_add(d1_size * elem_size)
	character accel_add(d1_block_size * elem_size)
	integer i
	integer size
	integer offset

	offset  = d1_offset*elem_size
	size = d1_size * elem_size
	do i = 1,size
	   host_add (offset + i) = accel_add (i)
	end do
	end

!>  Stub for copying a 1D memory zone from the hardware accelerator to the
!>  host.
!>
!>  Do not change the place of the pointers in the API. The host address
!>  is always in the first position...
!>
!>  This function could be quite simpler but is designed by symmetry with
!>  other functions.
!>
!>  @param[in] elem_size is the size of one element of the array in
!>  byte
!>
!>  @param[in] d1_size is the number of elements in the array. It is not
!>  used but here for symmetry with functions of higher dimensionality
!>
!>  @param[in] d1_size is the number of elements in the array. It is not
!>  used but here for symmetry with functions of higher dimensionality
!>
!>  @param[in] d1_block_size is the number of element to transfer
!>
!>  @param[in] d1_offset is element order to start the transfer from
!>
!>  @param[in] host_add point to the array on the host to read
!>
!>  @param[out] accel_add refer to the compact memory area to write
!>  data. In the general case, accel_add may be seen as a unique idea
!>  (FIFO) and not some address in some memory space.

	subroutine P4A_COPY_TO_ACCEL_1D(elem_size, d1_size,
     &  d1_block_size, d1_offset, host_add, accel_add)

	integer d1_size
	integer elem_size
	integer d1_block_size
	integer d1_offset
	character host_add(d1_size * elem_size)
	character accel_add(d1_block_size * elem_size)
	integer i
	integer size
	integer offset

	offset  = d1_offset*elem_size
	size = d1_size * elem_size
	do i = 1,size
	    accel_add (i) = host_add (offset + i)
	end do
	end

!>  Stub for copying a 2D memory zone from the host to a compact memory
!>  zone in the hardware accelerator.

	subroutine P4A_COPY_TO_ACCEL_2D (elem_size, d1_size, d2_size,
     &  d1_block_size, d2_block_size, d1_offset, d2_offset, host_add,
     &  accel_add)

	integer d1_size
	integer d2_size
	integer elem_size
	integer d1_block_size
	integer d2_block_size
	integer d1_offset
	integer d2_offset
	character host_add(d1_size * elem_size, d2_size * elem_size)
	character accel_add(d1_block_size * elem_size,
     &                      d2_block_size * elem_size)
	integer i_1
	integer i_2
	integer offset_1
	integer offset_2

	offset_1  = d1_offset*elem_size
	offset_2  = d2_offset*elem_size
	do i_2 = 1, d2_block_size * elem_size
	   do i_1 = 1, d1_block_size * elem_size
	       accel_add (i_1, i_2) = host_add (offset_1 + i_1,
     &                                          offset_2 + i_2)
	   end do
	end do
	end

!>  Stub for copying memory from the hardware accelerator to a 2D array in
!>  the host.

	subroutine P4A_COPY_FROM_ACCEL_2D (elem_size, d1_size, d2_size,
     &  d1_block_size, d2_block_size, d1_offset, d2_offset, host_add,
     &  accel_add)

	integer d1_size
	integer d2_size
	integer elem_size
	integer d1_block_size
	integer d2_block_size
	integer d1_offset
	integer d2_offset
	character host_add(d1_size * elem_size, d2_size * elem_size)
	character accel_add(d1_block_size * elem_size,
     &                      d2_block_size * elem_size)
	integer i_1
	integer i_2
	integer offset_1
	integer offset_2

	offset_1  = d1_offset*elem_size
	offset_2  = d2_offset*elem_size
	do i_2 = 1, d2_block_size * elem_size
	   do i_1 = 1, d1_block_size * elem_size
	      host_add (offset_1 + i_1, offset_2 + i_2) =
     &                                accel_add (i_1, i_2)
	   end do
	end do
	end

!>  Stub for allocating memory on the hardware accelerator.
!>
!>  @param[out] address is the address of a variable that is updated by
!>  this macro to contains the address of the allocated memory block
!>  @param[in] size is the size to allocate in bytes
	subroutine P4A_ACCEL_MALLOC(address, size)
	integer size
	integer address
! Do nothing since it is not representable in Fortran 77...
	end

!>  Stub for freeing memory on the hardware accelerator.
!>
!>  @param[in] address is the address of a previously allocated memory
!>  zone on the hardware accelerator
	subroutine P4A_ACCEL_FREE(address)
	integer address
! Do nothing since it is not representable in Fortran 77...
	end
!> @}
!> @}


text:
SUBROUTINE paircal_weaklib &
           ( enu, enubar, cmpe, t, j0i, j0ii, j1i, j1ii )
!-----------------------------------------------------------------------
!
!    Author:       R. Chu, Dept. Phys. & Astronomy
!                  U. Tennessee, Knoxville
!
!    Created:      10/23/2018
!
!    Purpose:
!      To integrates the quantities
!
!          Fe(Ee)*Febar(Enu + Enubar - Ee)*Phi(Enu,Enubar,Ee)
!
!      for production and
!
!      [1-Fe(Ee)]*[1-Febar(Enu + Enubar - Ee)]*Phi(Enu,Enubar,Ee)
!
!      for annihilation.
!
!  Fe                   : electron occupation number
!  Febar                : positron occupation number
!  Fe                   : electron energy
!  Enu                  : neutrino energy
!  Enubar               : antineutrino energy
!
!      Phi(Enu,Enubar,Ee) = cpair1*j0i + cpair2*j0ii
!
!    Subprograms called:
!  pr_w_gt_wp_e_lt_wp   : to integrate from 0 to wp for the case w > wp
!  pr_w_gt_wp_lt_e_lt_w : to integrate from wp to w for the case w > wp
!  pr_w_gt_wp_w_lt_e    : to integrate from w to w+wp for the case w > wp
!  pr_w_lt_wp_e_lt_w    : to integrate from 0 to w for the case w < wp
!  pr_w_lt_wp_e_lt_wp   : to integrate from w to wp for the case w < wp
!  pr_w_lt_wp_wp_lt_e   : to integrate from wp to w+wp for the case w < wp
!
!    Input arguments:
!  enu                  : neutrino energy [MeV]
!  enubar               : antineutrino energy [MeV]
!  cmpe                 : electron chemical potential [MeV]
!  t                    : matter temperature [K]
!
!    Output arguments:
!  j0i                  : zero moment of the "i" pair annihilation kernal
!  j0ii                 : zero moment of the "ii" pair annihilation kernal
!  j1i                  : first moment of the "i" pair annihilation kernal
!  j1ii                 : first moment of the "ii" pair annihilation kernal
!
!    Variables that must be passed through common:
!      none
!
!-----------------------------------------------------------------------

USE kind_module, ONLY: double
USE numerical_module, ONLY: zero, one
USE physcnst_module, ONLY: kmev

USE nes_module
USE pair_module, ONLY: g2, coef

IMPLICIT none

!-----------------------------------------------------------------------
!        Input variables.
!-----------------------------------------------------------------------

REAL(KIND=double), INTENT(in)    :: enu           ! zone centered neutrino energy [MeV]
REAL(KIND=double), INTENT(in)    :: enubar        ! zone centered antineutrino energy [MeV]
REAL(KIND=double), INTENT(in)    :: cmpe          ! electron chemical potential [MeV]
REAL(KIND=double), INTENT(in)    :: t             ! temperature [K]

!-----------------------------------------------------------------------
!        Output variables.
!-----------------------------------------------------------------------

REAL(KIND=double), INTENT(out)   :: j0i           ! zero moment of the "i" pair annihilation kernal
REAL(KIND=double), INTENT(out)   :: j0ii          ! zero moment of the "ii" pair annihilation kernal
REAL(KIND=double), INTENT(out)   :: j1i           ! first moment of the "i" pair annihilation kernal
REAL(KIND=double), INTENT(out)   :: j1ii          ! first moment of the "ii" pair annihilation kernal

!-----------------------------------------------------------------------
!        Local variables
!-----------------------------------------------------------------------

REAL(KIND=double)                :: tmev          ! temperature [MeV]
REAL(KIND=double)                :: eta           ! cmpe/tmev
REAL(KIND=double)                :: beta          ! 1/tmev

REAL(KIND=double)                :: fexp          ! exponential

EXTERNAL fexp

!-----------------------------------------------------------------------
!-----------------------------------------------------------------------

!-----------------------------------------------------------------------
!  Initialize.
!
!  j0i, etc. have units of 1/[ MeV3 cm ].
!-----------------------------------------------------------------------

w                  = enu
w2                 = w * w
w3                 = w2 * w
w4                 = w3 * w
w5                 = w4 * w
wp                 = enubar
wp2                = wp * wp
wp3                = wp2 * wp
wp4                = wp3 * wp
wp5                = wp4 * wp
wwp                = w * wp
w_p_wp             = w + wp
w_p_wp2            = w_p_wp * w_p_wp
w_p_wp3            = w_p_wp2 * w_p_wp
tmev               = t * kmev
beta               = one/tmev
eta                = beta * cmpe

j0i                = zero
j0ii               = zero
j1i                = zero
j1ii               = zero

!-----------------------------------------------------------------------
!  w > wp
!-----------------------------------------------------------------------

IF ( w >= wp ) THEN

  CALL pr_w_gt_wp_e_lt_wp( zero, wp, eta, beta, j0i, j0ii, j1i, j1ii )
  CALL pr_w_gt_wp_lt_e_lt_w( wp, w, eta, beta, j0i, j0ii, j1i, j1ii )
  CALL pr_w_gt_wp_w_lt_e( w, w_p_wp, eta, beta, j0i, j0ii, j1i, j1ii )

ELSE

!-----------------------------------------------------------------------
!  w < wp
!-----------------------------------------------------------------------

  CALL pr_w_lt_wp_e_lt_w( zero, w, eta, beta, j0i, j0ii, j1i, j1ii )
  CALL pr_w_lt_wp_e_lt_wp( w, wp, eta, beta, j0i, j0ii, j1i, j1ii )
  CALL pr_w_lt_wp_wp_lt_e( wp, w_p_wp, eta, beta, j0i, j0ii, j1i, j1ii )

END IF

!-----------------------------------------------------------------------
!  .Final touches
!-----------------------------------------------------------------------

j0i                = j0i /( enu * enu * enubar * enubar )
j0ii               = j0ii/( enu * enu * enubar * enubar )
j1i                = j1i /( enu * enu * enubar * enubar )
j1ii               = j1ii/( enu * enu * enubar * enubar )

j0i                = coef * j0i
j0ii               = coef * j0ii
j1i                = coef * j1i
j1ii               = coef * j1ii

RETURN

END SUBROUTINE paircal_weaklib

max_stars_repo_name: srichers/weaklib


!> This module is a placeholder for any user defined wind types.  The end user can use this as a template for their code.
!! @note  This module does not need to exactly conform to the FAST Modularization Framework standards.  Three routines are required
!! though:
!!    -- IfW_UserWind_Init          -- Load or create any wind data.  Only called at the start of FAST.
!!    -- IfW_UserWind_CalcOutput    -- This will be called at each timestep with a series of data points to give wind velocities at.
!!    -- IfW_UserWind_End           -- clear out any stored stuff.  Only called at the end of FAST.
MODULE IfW_UserWind
!**********************************************************************************************************************************
! LICENSING
! Copyright (C) 2015-2016  National Renewable Energy Laboratory
!
!    This file is part of InflowWind.
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!     http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.
!
!**********************************************************************************************************************************

   USE                                       NWTC_Library
   USE                                       IfW_UserWind_Types

   IMPLICIT                                  NONE
   PRIVATE

   TYPE(ProgDesc),   PARAMETER               :: IfW_UserWind_Ver = ProgDesc( 'IfW_UserWind', 'v0.00.00', '00-Jan-0000' )

   PUBLIC                                    :: IfW_UserWind_Init
   PUBLIC                                    :: IfW_UserWind_End
   PUBLIC                                    :: IfW_UserWind_CalcOutput

CONTAINS

!====================================================================================================

!----------------------------------------------------------------------------------------------------
!> A subroutine to initialize the UserWind module. This routine will initialize the module.
!----------------------------------------------------------------------------------------------------
SUBROUTINE IfW_UserWind_Init(InitData, ParamData, MiscVars, Interval, InitOutData, ErrStat, ErrMsg)

   IMPLICIT                                                       NONE

   CHARACTER(*),           PARAMETER                           :: RoutineName="IfW_UserWind_Init"

      ! Passed Variables

            !  Anything this code needs to be able to generate or read its data in should be passed into here through InitData.
   TYPE(IfW_UserWind_InitInputType),            INTENT(IN   )  :: InitData          !< Input data for initialization.

            !  Store all data that does not change during the simulation in here (including the wind data field).  This cannot be changed later.
   TYPE(IfW_UserWind_ParameterType),            INTENT(  OUT)  :: ParamData         !< Parameters.

            !  Store things that change during the simulation (indices to arrays for quicker searching etc).
   TYPE(IfW_UserWind_MiscVarType),              INTENT(  OUT)  :: MiscVars          !< Misc variables for optimization (not copied in glue code)

            !  Anything that should be passed back to the InflowWind or higher modules regarding initialization.
   TYPE(IfW_UserWind_InitOutputType),           INTENT(  OUT)  :: InitOutData       !< Initial output.

   REAL(DbKi),                                  INTENT(IN   )  :: Interval          !< Do not change this!!

      ! Error handling
   INTEGER(IntKi),                              INTENT(  OUT)  :: ErrStat           !< determines if an error has been encountered
   CHARACTER(*),                                INTENT(  OUT)  :: ErrMsg            !< A message about the error.  See NWTC_Library info for ErrID_* levels.

      ! local variables
   ! Put local variables used during initializing your wind here.  DO NOT USE GLOBAL VARIABLES EVER!
   INTEGER(IntKi)                                              :: UnitWind          ! Use this unit number if you need to read in a file.

      ! Temporary variables for error handling
   INTEGER(IntKi)                                              :: TmpErrStat        ! Temp variable for the error status
   CHARACTER(ErrMsgLen)                                        :: TmpErrMsg         ! temporary error message

      !-------------------------------------------------------------------------------------------------
      ! Set the Error handling variables
      !-------------------------------------------------------------------------------------------------

   ErrStat     = ErrID_None
   ErrMsg      = ""

      ! Get a unit number to use

   CALL GetNewUnit(UnitWind, TmpErrStat, TmpErrMsg)
   CALL SetErrStat(TmpErrStat,TmpErrMsg,ErrStat,ErrMsg,RoutineName)
   IF (ErrStat >= AbortErrLev) RETURN

      !-------------------------------------------------------------------------------------------------
      ! Copy things from the InitData to the ParamData.  If you need to store it for later calculations,
      !  copy it over now.
      !-------------------------------------------------------------------------------------------------

!   ParamData%RefHt            =  InitData%ReferenceHeight
!   ParamData%RefLength        =  InitData%RefLength

      !-------------------------------------------------------------------------------------------------
      ! Open the file for reading.  Proceed with file parsing etc.  Populate your wind field here.
      !-------------------------------------------------------------------------------------------------

!   CALL OpenFInpFile (UnitWind, TRIM(InitData%WindFileName), TmpErrStat, TmpErrMsg)
!   CALL SetErrStat(TmpErrStat,TmpErrMsg,ErrStat,ErrMsg,RoutineName)
!   IF ( ErrStat >= AbortErrLev ) RETURN

      !-------------------------------------------------------------------------------------------------
      ! Set the MiscVars:
      !-------------------------------------------------------------------------------------------------

    MiscVars%DummyMiscVar = 0

      !-------------------------------------------------------------------------------------------------
      ! Set the InitOutput information. Set Any outputs here.
      !-------------------------------------------------------------------------------------------------

   InitOutdata%Ver         = IfW_UserWind_Ver

      ! REMOVE THIS MESSAGE IF YOU WRITE CODE IN THIS MODULE
   CALL SetErrStat(ErrID_Fatal,' This module has not been written yet.',ErrStat,ErrMsg,RoutineName)

   RETURN

END SUBROUTINE IfW_UserWind_Init

!====================================================================================================

!-------------------------------------------------------------------------------------------------
!>  This routine and its subroutines calculate the wind velocity at a set of points given in
!!  PositionXYZ.  The UVW velocities are returned in OutData%Velocity
!!
!! @note    This routine may be called multiple times in a single timestep!!!
!!
!! @note    The PositionXYZ coordinates have been rotated into the wind coordinate system where the
!!          primary wind flow is along the X-axis.  The rotations to PropagationDir are taken care of
!!          in the InflowWind_CalcOutput subroutine which calls this routine.
!-------------------------------------------------------------------------------------------------
SUBROUTINE IfW_UserWind_CalcOutput(Time, PositionXYZ, ParamData, Velocity, DiskVel, MiscVars, ErrStat, ErrMsg)

   IMPLICIT                                                       NONE

   CHARACTER(*),           PARAMETER                           :: RoutineName="IfW_UserWind_CalcOutput"

      ! Passed Variables
   REAL(DbKi),                                  INTENT(IN   )  :: Time              !< time from the start of the simulation
   REAL(ReKi),                                  INTENT(IN   )  :: PositionXYZ(:,:)  !< Array of XYZ coordinates, 3xN
   TYPE(IfW_UserWind_ParameterType),            INTENT(IN   )  :: ParamData         !< Parameters
   REAL(ReKi),                                  INTENT(INOUT)  :: Velocity(:,:)     !< Velocity output at Time    (Set to INOUT so that array does not get deallocated)
   REAL(ReKi),                                  INTENT(  OUT)  :: DiskVel(3)        !< HACK for AD14: disk velocity output at Time
   TYPE(IfW_UserWind_MiscVarType),              INTENT(INOUT)  :: MiscVars          !< Misc variables for optimization (not copied in glue code)

      ! Error handling
   INTEGER(IntKi),                              INTENT(  OUT)  :: ErrStat           !< error status
   CHARACTER(*),                                INTENT(  OUT)  :: ErrMsg            !< The error message

      ! local counters
   INTEGER(IntKi)                                              :: PointNum          ! a loop counter for the current point

      ! local variables
   INTEGER(IntKi)                                              :: NumPoints         ! Number of points passed in

      ! temporary variables
   INTEGER(IntKi)                                              :: TmpErrStat        ! temporary error status
   CHARACTER(ErrMsgLen)                                        :: TmpErrMsg         ! temporary error message

      !-------------------------------------------------------------------------------------------------
      ! Initialize some things
      !-------------------------------------------------------------------------------------------------

   ErrStat     = ErrID_None
   ErrMsg      = ""

      ! The array is transposed so that the number of points is the second index, x/y/z is the first.
      ! This is just in case we only have a single point, the SIZE command returns the correct number of points.
   NumPoints   =  SIZE(PositionXYZ,DIM=2)

      ! Step through all the positions and get the velocities
   DO PointNum = 1, NumPoints

! Place code to retrieve the windspeed at a given point here.

      ! Some generic error handling if you want it when a calculation fails for some reason:
      !
      !   ! Error handling
      !CALL SetErrStat(TmpErrStat,TmpErrMsg,ErrStat,ErrMsg,RoutineName)
      !IF (ErrStat >= AbortErrLev) THEN
      !   TmpErrMsg=  " Error calculating the wind speed at position ("//   &
      !               TRIM(Num2LStr(PositionXYZ(1,PointNum)))//", "// &
      !               TRIM(Num2LStr(PositionXYZ(2,PointNum)))//", "// &
      !               TRIM(Num2LStr(PositionXYZ(3,PointNum)))//") in the wind-file coordinates"
      !   CALL SetErrStat(TmpErrStat,TmpErrMsg,ErrStat,ErrMsg,RoutineName)
      !   RETURN
      !ENDIF

   ENDDO

      ! an average wind speed, required for AD14
   DiskVel = 0.0_ReKi

      ! REMOVE THIS MESSAGE IF YOU WRITE CODE IN THIS MODULE
   CALL SetErrStat(ErrID_Fatal,' This module has not been written yet.',ErrStat,ErrMsg,RoutineName)

   RETURN

END SUBROUTINE IfW_UserWind_CalcOutput

!====================================================================================================

!----------------------------------------------------------------------------------------------------
!>  This routine closes any open files and clears all data stored in UserWind derived Types
!!
!! @note  This routine does not satisfy the Modular framework.  The InputType is not used, rather
!!          an array of points is passed in.
!! @date:  16-Apr-2013 - A. Platt, NREL.  Converted to modular framework. Modified for NWTC_Library 2.0
!----------------------------------------------------------------------------------------------------
SUBROUTINE IfW_UserWind_End( ParamData, MiscVars, ErrStat, ErrMsg)

   IMPLICIT                                                       NONE

   CHARACTER(*),           PARAMETER                           :: RoutineName="IfW_UserWind_End"

      ! Passed Variables
   TYPE(IfW_UserWind_ParameterType),            INTENT(INOUT)  :: ParamData         !< Parameters
   TYPE(IfW_UserWind_MiscVarType),              INTENT(INOUT)  :: MiscVars          !< Misc variables for optimization (not copied in glue code)

      ! Error Handling
   INTEGER(IntKi),                              INTENT(  OUT)  :: ErrStat           !< determines if an error has been encountered
   CHARACTER(*),                                INTENT(  OUT)  :: ErrMsg            !< Message about errors

      ! Local Variables
   INTEGER(IntKi)                                              :: TmpErrStat        ! temporary error status
   CHARACTER(ErrMsgLen)                                        :: TmpErrMsg         ! temporary error message

      !-=- Initialize the routine -=-

   ErrMsg   = ''
   ErrStat  = ErrID_None

      ! Destroy parameter data

   CALL IfW_UserWind_DestroyParam(       ParamData,     TmpErrStat, TmpErrMsg )
   CALL SetErrStat( TmpErrStat, TmpErrMsg, ErrStat, ErrMsg, RoutineName )

      ! Destroy the misc data

   CALL IfW_UserWind_DestroyMisc(  MiscVars,   TmpErrStat, TmpErrMsg )
   CALL SetErrStat( TmpErrStat, TmpErrMsg, ErrStat, ErrMsg, RoutineName )

END SUBROUTINE IfW_UserWind_End

!====================================================================================================
!====================================================================================================
!====================================================================================================
END MODULE IfW_UserWind


text:
      subroutine fslave()

      include 'p4f.h'

      real a(600000)
      integer type, from, next, procid, length, numsl, retcde, recvlen
      integer tagcnt, tagdat, tagend, done
      parameter (tagcnt = 10)
      parameter (tagdat = 20)
      parameter (tagend = 30)

      numsl = p4ntotids() - 1
      procid = p4myid()
      print *,'slave ',procid,' has started'
      call p4flush()
      if (procid .eq. numsl) then
	     next = 0
      else
	     next = procid + 1
      endif
      length = 8
      type = tagcnt
      from = -1
      call p4recv(type,from,n,length,recvlen,retcde)
      print *,'SLAVE ',procid,' received from = ',from,' type = ',type
      call p4flush()

c Initialize socket connections between the slaves
      type = tagcnt
      from = -1
      call p4recv(type,from,a,length,recvlen,retcde)
      call p4sendr(tagcnt,next,a,recvlen,retcde)

      length = 600000
c
	  if (procid .eq. 1) then
	     do 10 i = 6,19
		    do 11 k = 1,n
      type = i
      from = -1
      call p4recv(type,from,a,length,recvlen,retcde)
11          continue
10       continue
	     do 22 i = 6,19
			do 21 k = 1,n
      type = i
      from = -1
      call p4recv(type,from,a,length,recvlen,retcde)
21          continue
22       continue
	     do 23 i = 6,19
			do 24 k = 1,n
      type = i
      from = -1
      call p4recv(type,from,a,length,recvlen,retcde)
      call p4send(i,0,a,recvlen,retcde)
24          continue
23       continue
	     do 27 i = 6,19
			do 28 k = 1,n
      type = i
      from = -1
      call p4recv(type,from,a,length,recvlen,retcde)
      done = p4clock()
      call p4send(i,0,done,4,retcde)
28          continue
27       continue
      endif
c
	  do 30 i = 6,19
		 do 31 k = 1,n
      type = i
      from = -1
      call p4recv(type,from,a,length,recvlen,retcde)
      call p4send(i,next,a,recvlen,retcde)
31       continue
30    continue
c
	  do 40 i = 6,19
		 do 41 k = 1,n
      type = i
      from = -1
      call p4recv(type,from,a,length,recvlen,retcde)
41       continue
40    continue
c
      length = 0
      type = tagend
      from = 0
      call p4recv(type,from,a,length,recvlen,retcde)
999   print *,'Slave ',procid,' has been cleaned up'
      call p4flush()
      end

max_stars_repo_name: RWTH-OS/MP-MPICH

max_issues_repo_name: RWTH-OS/MP-MPICH

max_forks_repo_name: RWTH-OS/MP-MPICH


text: The Helge B. Olsen Furniture Studio...

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
!-- thRead.f90
!-- 4 Mar 92, Richard Maine: Version 1.0.

module th_read

  !-- Module for read access to time history files.
  !-- Does not support cmp2(elxsi) or enc1(sel) formats.
  !-- 19 Sep 90, Richard Maine.

  use precision
  use sysdep_io
  use string
  use th_read_gen
  use th_read_asc12
  use th_read_unc2
  use th_read_unc3
  use th_read_cmp3
  use th_read_net1

  implicit none
  private

  !-- Public parameters from th_read_gen
  public thr_ok, thr_eoi, thr_eod, thr_error

  logical, save :: th_read_initialized = .false.

  integer, parameter :: n_formats = 7
  integer, parameter :: usr1_code = 1, asc1_code = 2, asc2_code = 3, &
       unc2_code = 4, unc3_code = 5, cmp3_code = 6, net1_code = 7
  character, save :: format_names(n_formats)*8 = ' none '

  type fd_type  !-- fd is short for file_descriptor
    integer :: format_code
    logical :: ok_to_read
         !-- True when an attempt to read is allowed.
         !-- If false, the file must be repositioned before the next read.
    integer :: n_signals, n_requested
    real(r_kind) :: start_time, stop_time, prev_time
    integer :: thin_factor
    logical :: first_read
         !-- True on the first read of a time interval.
         !-- Used in thinning.
    type(gen_type), pointer :: gen
         !-- Generic data for the format-specific modules.
         !-- None of the internal structure should be referenced here.
  end type

  !-- Handles are public with private components.
  type, public :: th_read_handle_type
    private
    type(fd_type), pointer :: fd
  end type

  type(fd_type), pointer :: fd  !-- Scratch use only.  Not saved.

  !-- Public procedures.
  public open_th_read, close_th_read, inquire_th, request_th_signals
  public seek_th, read_th

  !-- Forward reference for private procedures.
  private read_th_format, read_raw_file

contains

  subroutine init_th_read

    !-- Initialize the th_read module.
    !-- Will automatically be called when needed.
    !-- 22 Jun 90, Richard Maine.

    !-------------------- executable code.

    !-- Return immediately if already done.
    if (th_read_initialized) return
    th_read_initialized = .true.

    format_names(asc1_code) = asc1_format_string
    format_names(asc2_code) = asc2_format_string
    format_names(unc2_code) = unc2_format_string
    format_names(unc3_code) = unc3_format_string
    format_names(cmp3_code) = cmp3_format_string
    format_names(net1_code) = net1_format_string
    return
  end subroutine init_th_read

  subroutine open_th_read (file_handle, file_name, file_format, &
       access_id, password, error)

    !-- Open a time history file for read access.
    !-- Note that, unlike in the old Fortran 77 routines,
    !-- this open does not establish a file position;
    !-- a call to seek_th is required before the first data access.
    !-- 19 Sept 90, Richard Maine.

    !-------------------- interface.
    type(th_read_handle_type), intent(out) :: file_handle
         !-- Identifies the file for subsequent reference.
         !-- Returns a null handle if the open fails.
    character*(*), intent(in) :: file_name
    character*(*), intent(in), optional :: file_format
         !-- Attempts automatic determination if this is blank or absent.
    character*(*), intent(in), optional :: access_id, password
         !-- Id and password for security authorization.
         !-- Some files may require specification of an acceptable
         !-- access_id and password to allow access.
         !-- Blank or omitted values imply that no special access
         !-- permissions are requested.
    logical, intent(out), optional :: error
         !-- Returns true if open fails.
         !-- Abort if open fails and this is not present.

    !-------------------- local.
    integer :: iostat, format_code
    character :: format_name*8, access_id_tmp*16, password_tmp*16, where*32
    logical :: sub_error

    !-------------------- executable code.

    if (.not. th_read_initialized) call init_th_read

    !-- Allocate a file handle.
    where = 'allocate'
    nullify(fd)
    allocate(fd, stat=iostat)
    file_handle%fd => fd
    if (iostat /= 0) goto 8000
    call allocate_th_read_gen(fd%gen, sub_error)
    if (sub_error) goto 8000

    !-- Determine the format.
    fd%format_code = 0
    format_name = ''
    if (present(file_format)) format_name = file_format
    if (format_name == '') call read_th_format(file_name, format_name)
    if (format_name == '') then
      where = 'format determination'; goto 8000; endif
    format_code = string_index(string=format_name, list=format_names)
    if (format_code==0) then
      where = 'unknown format: ' // format_name; goto 8000; endif

    !-- Handle defaults for security access.
    access_id_tmp = ''
    password_tmp = ''
    if (present(access_id)) access_id_tmp = access_id
    if (present(password)) password_tmp = password

    !-- Open the file according to the format.
    select case(format_code)
    case (asc1_code,asc2_code)
      call open_th_read_asc12(fd%gen, file_name, fd%n_signals, sub_error)
    case (unc2_code)
      call open_th_read_unc2(fd%gen, file_name, fd%n_signals, sub_error)
    case (unc3_code)
      call open_th_read_unc3(fd%gen, file_name, fd%n_signals, sub_error)
    case (cmp3_code)
      call open_th_read_cmp3(fd%gen, file_name, fd%n_signals, sub_error)
    case (net1_code)
      call open_th_read_net1(fd%gen, file_name, access_id_tmp, password_tmp, &
           fd%n_signals, sub_error)
    case default
      sub_error = .true.
    end select
    if (sub_error) then
      where = 'open format: ' // format_name; goto 8000; endif

    !-- Default to complete signal list.
    fd%n_requested = fd%n_signals

    !-- Normal return.
    fd%format_code = format_code
    fd%ok_to_read = .false.
    if (present(error)) error = .false.
    return

    !---------- error exit.
    8000 continue
    if (iostat /= 0) call write_sys_error(iostat)
    call write_error_msg('Open_th_read failed at ' // where)
    call write_error_msg('File: ' // file_name)
    if (associated(fd)) call close_th_read(file_handle)
    if (.not.present(error)) call error_halt
    error = .true.
    return
  end subroutine open_th_read

  subroutine close_th_read (file_handle)

    !-- Close file opened by open_th_read.
    !-- All errors are currently fatal.
    !-- 13 Aug 90, Richard Maine.

    !-------------------- interface.
    type(th_read_handle_type), intent(inout) :: file_handle
         !-- Returns a null handle on exit.

    !-------------------- executable code.

    !-- Quietly return if the handle is null; otherwise validate it.
    !-- Ideally, we should not be called with a null handle.
    !-- but we will allow it.
    fd => file_handle%fd
    if (.not. associated(fd)) return

    if (associated(fd%gen)) then

      !-- Close according to the format.
      select case (fd%format_code)
      case (asc1_code,asc2_code)
        call close_th_read_asc12(fd%gen)
      case (unc2_code)
        call close_th_read_unc2(fd%gen)
      case (unc3_code)
        call close_th_read_unc3(fd%gen)
      case (cmp3_code)
        call close_th_read_cmp3(fd%gen)
      case (net1_code)
        call close_th_read_net1(fd%gen)
      case (0)  !-- This may happen if called from open_th_read.
        continue
      end select

      !-- Free the handle.
      call free_th_read_gen(fd%gen)
    end if
    deallocate(file_handle%fd)
    return
  end subroutine close_th_read

  subroutine inquire_th (file_handle, n_signals, dt, file_title, &
       signal_names, eu_names, error)

    !-- Return information about a th_read file.
    !-- 26 Jun 90, Richard Maine.

    !-------------------- interface.
    type(th_read_handle_type), intent(in) :: file_handle
    integer, intent(out), optional :: n_signals
         !-- Number of signals available on the file.
    real(r_kind), intent(out), optional :: dt
         !-- Nominal sample interval.  0 if unknown.
    character*(*), intent(out), optional :: file_title
         !-- File title.  Blank if none.
    character*(*), optional, intent(out) :: signal_names(:)
         !-- Names of the signals known to be available.
         !-- Note that this list may be incomplete in some cases
         !-- where the only way to find out if a signal is available
         !-- is to ask for it (sad, but true).
    character*(*), optional, intent(out) :: eu_names(:)
         !-- Engineering units names for the currently requested signals.
         !-- Note that this corresponds to signal_names only if all
         !-- the signals are currently requested.  Blank if unknown.
    logical, intent(out), optional :: error
         !-- Returns true if an error occurs.
         !-- Abort if there is an error and this is not present.

    !-------------------- executable code.

    fd => file_handle%fd
    if (.not. associated(fd)) call error_halt('Closed th_read file_handle')

    if (present(n_signals)) n_signals = fd%n_signals
    if (present(dt)) dt = fd%gen%dt
    if (present(file_title)) file_title = fd%gen%file_title

    !-- Check array sizes.
    if (present(signal_names)) then
      if (size(signal_names) < fd%n_signals) &
           call error_halt('Signal_names vector too small in inquire_th.')
    end if
    if (present(eu_names)) then
      if (size(eu_names) < fd%n_requested) &
           call error_halt('Eu_names vector too small in inquire_th.')
    end if

    !-- Obtain signal names and eu names according to format if required.
    if (present(signal_names) .or. present(eu_names)) then
      select case (fd%format_code)
      case (asc1_code,asc2_code,unc2_code,unc3_code,cmp3_code,net1_code)
        call inquire_th_gen(fd%gen, signal_names, eu_names)
      end select
    end if

    !-- Normal exit.
    if (present(error)) error = .false.
    return
  end subroutine inquire_th

  subroutine request_th_signals (file_handle, requested_signals, &
       print_warning, signal_found, all_found, error)

    !-- Specify signals to be read from a time history file.
    !-- Terminates the current seek interval.
    !-- 19 Sept 90, Richard Maine.

    !-------------------- interface.
    type(th_read_handle_type), intent(in) :: file_handle
    character*(*), intent(in) :: requested_signals(:)
         !-- Requested signal names.
    logical, intent(in), optional :: print_warning
         !-- Should warning messages be printed for missing signals?
         !-- Default is .true.
    logical, intent(out), optional :: signal_found(:)
         !-- Indicates which requested signals were found.
         !-- If present, must be the same size as requested_signals.
    logical, intent(out), optional :: all_found
         !-- True if all requested non-blank signals were found.
    logical, intent(out), optional :: error
         !-- True if an error occurs.
         !-- Abort if an error occurs and this is not present.
         !-- This indicates a serious error (usually i/o).
         !-- Failure to find requested signals is not considered an error.
         !-- The signal_found argument and the resulting signal list
         !-- are undefined if this returns true.

    !-------------------- local.
    integer :: i, n_requested
    logical :: all_good, sub_error, warn
    logical :: found(size(requested_signals))

    !-------------------- executable code.

    fd => file_handle%fd
    if (.not. associated(fd)) call error_halt('Closed th_read file_handle')

    n_requested = size(requested_signals)
    if (present(signal_found)) then
      if (size(signal_found) /= n_requested) &
           call error_halt('Inconsistent sizes in request_th_signals')
    end if

    fd%n_requested = -1
    fd%ok_to_read = .false.
    all_good = .false.

    !-- Request signals according to format.
    sub_error = .false.
    select case (fd%format_code)
    case (asc1_code,asc2_code,unc2_code,unc3_code,cmp3_code)
      call request_th_gen(fd%gen, requested_signals, found)
    case (net1_code)
      call request_th_net1(fd%gen, requested_signals, found, sub_error)
    end select
    if (sub_error) goto 8000

    !-- Print optional error messages.
    all_good = all(found .or. (requested_signals==''))
    warn = .true.
    if (present(print_warning)) warn = print_warning
    if (warn .and. .not. all_good) then
      do i = 1 , n_requested
        if ((.not. found(i)) .and. (requested_signals(i) /= '')) &
             call write_error_msg('Signal ' // requested_signals(i) // &
             ' not found.')
      end do
    end if

    !-- Return optional arguments.
    fd%n_requested = n_requested
    if (present(signal_found)) signal_found = found

    !-- Both normal and error exits return through here.
    8000 continue
    if (present(all_found)) all_found = all_good
    if (sub_error .and. .not.present(error)) &
         call error_halt('Error in request_th_signals.')
    if (present(error)) error = sub_error
    return
  end subroutine request_th_signals

  subroutine seek_th (file_handle, start_time, stop_time, thin, error)

    !-- Seek to a specified time interval on a time history file.
    !-- 19 Sept 90, Richard Maine.

    !-------------------- interface.
    type(th_read_handle_type), intent(in) :: file_handle
    real(r_kind), intent(in), optional :: start_time, stop_time
         !-- Default seek interval is 0-24 hours.
    integer, intent(in), optional :: thin
         !-- Thinning factor for data frames.  Default is 1.
         !-- Must be >=1.  Illegal values currently are ignored.
    logical, intent(out), optional :: error
         !-- True if an error occurs.  It is not considered an error
         !-- to seek to an interval that has no data frames.

    !-------------------- local.
    logical :: sub_error

    !-------------------- executable code.

    fd => file_handle%fd
    if (.not. associated(fd)) call error_halt('Closed th_read file_handle')

    !-- Don't seek if the signal list is undefined (from an error).
    sub_error = fd%n_requested < 0
    if (sub_error) goto 8000

    !-- Save time interval specifications.
    if (present(start_time)) then
      fd%start_time = start_time
    else
      fd%start_time = 0.
    end if
    if (present(stop_time)) then
      fd%stop_time = stop_time
    else
      fd%stop_time = 86400._r_kind
    end if
    if (present(thin)) then
      fd%thin_factor = max(thin,1)
    else
      fd%thin_factor = 1
    end if
    fd%prev_time = -big_real
    fd%first_read = .true.

    !-- Call lower level routines to do the seek.

    !-- Note that the low level routines are allowed to seek to
    !-- any earlier time (for instance to the first available frame).
    !-- The high level read will discard any data before the requested
    !-- start time.  The decision of how much to do in the low
    !-- level routine is purely one of efficiency.

    !-- If the lower level routine handles thinning, then we must
    !-- set fd%thin_factor to 1 afterwards to avoid double thinning.

    sub_error = .true.
    select case (fd%format_code)
    case (asc1_code,asc2_code)
      call seek_th_asc12(fd%gen, fd%start_time, sub_error)
    case (unc2_code)
      call seek_th_unc2(fd%gen, fd%start_time, sub_error)
    case (unc3_code)
      call seek_th_unc3(fd%gen, fd%start_time, sub_error)
    case (cmp3_code)
      call seek_th_cmp3(fd%gen, fd%start_time, sub_error)
    case (net1_code)
      call seek_th_net1(fd%gen, fd%start_time, fd%stop_time, fd%thin_factor, &
           sub_error)
    end select

    !-- Normal or error exit.
    8000 continue
    fd%ok_to_read = .not. sub_error
    if (sub_error .and. .not.present(error)) &
         call error_halt('Error in seek_th.')
    if (present(error)) error = sub_error
    return
  end subroutine seek_th

  subroutine read_th (file_handle, time, data, status)

    !-- Read a frame from a th file.
    !-- 19 Sept 90, Richard Maine.

    !-------------------- interface.
    type(th_read_handle_type), intent(in) :: file_handle
    real(r_kind), intent(out) :: time     !-- Frame time.
    real(r_kind), intent(out) :: data(:)  !-- Frame data.
    integer, intent(out) :: status
         !-- Returns 0 for valid data frame.
         !-- 1 = end of requested interval reached.
         !-- 2 = end of available data reached.
         !-- 3 = error.

    !-------------------- local.
    integer :: thin_count, thin_factor, n_req

    !-------------------- executable code.

    fd => file_handle%fd
    if (.not. associated(fd)) call error_halt('Closed th_read file_handle')

    status = 3
    if (.not. fd%ok_to_read) return
    fd%ok_to_read = .false.

    n_req = fd%n_requested
    if (size(data) < n_req) call error_halt('data size wrong in read_th')

    !-- Read a frame according to format.
    !-- Error message for frames out of time order.
    !-- Skip frames prior to the requested interval.
    !-- Stop on frames after the requested interval.
    thin_factor = fd%thin_factor
    if (fd%first_read) thin_factor = 1
    fd%first_read = .false.
    thin_loop: do thin_count = 1 , thin_factor
      seek_loop: do
        status = 3
        select case (fd%format_code)
        case (asc1_code,asc2_code)
          call read_th_asc12(fd%gen, time, data(1:n_req), status)
        case (unc2_code)
          call read_th_unc2(fd%gen, time, data(1:n_req), status)
        case (unc3_code)
          call read_th_unc3(fd%gen, time, data(1:n_req), status)
        case (cmp3_code)
          call read_th_cmp3(fd%gen, time, data(1:n_req), status)
        case (net1_code)
          call read_th_net1(fd%gen, time, data(1:n_req), status)
        end select
        if (status /= 0) return
        if (time < fd%prev_time) then
          call write_error_msg('Time out of order in read_th.')
          status = 3
          return
        end if
        fd%prev_time = time
        if (time >= fd%start_time) exit seek_loop
      end do seek_loop
      if (time > fd%stop_time) then
        status = 1
        return
      end if
    end do thin_loop

    !-- Normal exit.
    fd%ok_to_read = .true.
    status = 0
    return
  end subroutine read_th

  subroutine read_th_format (file_name, file_format)

    !-- Determine the format of a time history file for open_th_read.
    !-- 22 Jun 90, Richard Maine.

    !-------------------- interface.
    character*(*), intent(in) :: file_name
    character*(*), intent(out) :: file_format  !-- Returns blank on failure.

    !-------------------- local.
    character :: data*40, key_string*8
    logical :: error
    integer :: i, j

    !-------------------- executable code.

    file_format = ''
    call read_raw_file (file_name, data, error)
    if (error) return

    !-- Find the format field.
    !-- Explicitly down_casing protects against source code case changes.
    key_string = lower_case('format  ')
    data = lower_case(data)
    i = index(string=data, substring=key_string)

    !-- xtract field, stripping embedded blanks.
    if (i > 0) then
      j = 0
      do i = i+8 , min(i+15,len(data))
        if (data(i:i) /= ' ') then
          j = j + 1
          if (j > len(file_format)) exit
          file_format(j:j) = data(i:i)
        end if
      end do
    end if

    if (file_format == '') &
      call write_error_msg('No format field in th_read file.')
    return
  end subroutine read_th_format

  subroutine read_raw_file (file_name, data, error)

    !-- Read the first bytes from a file of unknown format.
    !-- System dependent.
    !-- This routine must open and read data from a file without first
    !-- knowing the file format, including such things as whether the
    !-- file is formatted, unformatted, sequential, or direct.
    !-- It is acceptable to include low-level system record-control
    !-- or block-control headers in the data returned; the calling code
    !-- will scan past such headers to find the desired data.
    !-- Generic version, insomuch as we can.
    !-- This version uses direct access formatted i/o.
    !-- Alternatives include non-advancing or direct access unformatted.
    !-- 22 Jun 90, Richard Maine.

    !-------------------- interface.
    character*(*), intent(in) :: file_name
    character*(*), intent(out) :: data
    logical, intent(out) :: error

    !-------------------- local.
    integer :: lun, iostat

    !-------------------- executable code.

    !-- Try to open the file.
    data = ''
    call assign_lun(lun)
    open(lun, file=file_name, status='old', action='read', iostat=iostat, &
         form='formatted', access='direct', recl=len(data))
    error = iostat /= 0
    if (iostat /= 0) then
      call write_sys_error(iostat)
      call write_error_msg('Open_th_read unable to open file.')
      call release_lun(lun)
      return
    end if

    read(lun, '(a)', rec=1, iostat=iostat) data

    !-- close file and exit.
    error = iostat /= 0
    if (iostat /= 0) then
      call write_sys_error(iostat)
      call write_error_msg('Empty or bad file in open_th_read.')
    end if
    close(lun)
    call release_lun(lun)
    return
  end subroutine read_raw_file

end module th_read

max_stars_repo_name: brucegua/moocos

max_issues_repo_name: brucegua/moocos

max_forks_repo_name: brucegua/moocos


text:
Fiber and polymer sciences is a majors major offered by the Textiles and Clothing department in the College of Agricultural and Environmental Sciences College of Agriculture and Environmental Sciences for which the classes seem to be taught by the Textiles and Clothing Graduate Group.  Upon graduation, majors are awarded a Bachelor of Science degree.

The Major Program:
The fiber and polymer science major is concerned with the physical, chemical, and structural properties of fibers and polymers and how these relate to fiber and polymer performance and enduse.

All students in this major take a common core of course work in chemistry, physics, and mathematics, and depth subject matter in fiber and polymer science, organic and physical chemistry, and technical writing. In the restricted electives, students select courses from areas such as computer science and mathematics, chemistry, marketing and management, material and advanced fiber and polymer science, and textiles.

Career Alternatives:
The major prepares the student for a career in a wide range of industries in the areas of research and development, technical marketing and management, production, quality control, and science teaching (on completion of an additional year in the teaching credential program). The companies employing Fiber and Polymer Science graduates are in the fiber, polymer, industrial product, textile and/or chemical business. Graduates are prepared to enter the graduate program in textiles or agricultural and environmental chemistry with a specialization in fiber and polymer chemistry, and fiber and polymer science programs at other universities.