text:
program phaml_master
use phaml
implicit none
type(phaml_solution_type) :: soln
call phaml_create(soln,nproc=4)
call phaml_solve_pde(soln,print_grid_when=FINAL,print_grid_who=MASTER, &
                     print_error_when=FINAL,print_error_who=MASTER, &
                     print_errest_what=LINF_ERREST, &
                     term_Linf_err=2.5e-4_my_real)
call phaml_destroy(soln)
end program phaml_master

max_stars_repo_name: qsnake/phaml

max_issues_repo_name: qsnake/phaml

max_forks_repo_name: qsnake/phaml


! { dg-do run }
! Tests the fix for PR23446. Based on PR example.
! Contributed by Paul Thomas  <pault@gcc.gnu.org>
!
! Tests furthermore the fix for PR fortran/29916.
! Test contributed by Marco Restelli <mrestelli@gmail.com>
!
PROGRAM TST
  INTEGER IMAX
  INTEGER :: A(4) = 1
  IMAX=2

  CALL S(A)
  CALL T(A)
  CALL U(A)
  if ( ALL(A.ne.(/2,2,3,4/))) STOP 1
  if ( ALL(F().ne.(/2.0,2.0/))) STOP 2

CONTAINS
  SUBROUTINE S(A)
    INTEGER A(IMAX)
    a = 2
  END SUBROUTINE S
  SUBROUTINE T(A)
    INTEGER A(3:IMAX+4)
    A(5:IMAX+4) = 3
  END SUBROUTINE T
  SUBROUTINE U(A)
    INTEGER A(2,IMAX)
    A(2,2) = 4
  END SUBROUTINE U
  FUNCTION F()
    real :: F(IMAX)
    F = 2.0
  END FUNCTION F
ENDPROGRAM TST


text:
	FUNCTION PR_SALI  ( alti )
C************************************************************************
C* PR_SALI								*
C*									*
C* This function computes SALI from ALTI.  SALI is an abbreviated	*
C* altimeter code in inches which contains the unit digit and the	*
C* first two digits after the decimal points.  ALTI is multiplied by	*
C* 100 truncated, and the original tens digit dropped.  The following 	*
C* equation is used:							*
C*									*
C*              SALI = NINT ( MOD ( ALTI, 10 ) * 100 )			*
C*									*
C* REAL PR_SALI  ( ALTI )						*
C*									*
C* Input parameters:							*
C*	ALTI		REAL		Altimeter setting in inches	*
C*									*
C* Output parameters:							*
C*	PR_SALI		REAL		Abbreviated standard altimeter	*
C**									*
C* Log:									*
C* J. Nielsen/SUNYA	 8/90						*
C************************************************************************
        INCLUDE   'GEMPRM.PRM'
        INCLUDE   'ERMISS.FNC'
C------------------------------------------------------------------------
C*	Check for missing data.
C
	IF  ( ERMISS ( alti ) )  THEN
	    pr_sali = RMISSD
	  ELSE
C
C*	    Drop the leading tens digits.
C
	    aalt = AMOD ( alti, 10. )
C
C*	    Include the tenths digit.
C
	    aalt = aalt * 100.
	    PR_SALI = ANINT ( aalt )
	END IF
C*
	RETURN
	END

ext: f

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


text:
! =============================================================================
!
!> \file
!> \brief  Contains the Validate subroutine
!> \author CMJ (XCP-3; LANL)
!
!
! =============================================================================
subroutine validate(cond, msg)
   implicit none
   logical,      intent(in   ) :: cond
   character(*), intent(in   ) :: msg

   Insist(cond, msg)
   return
end subroutine validate

max_stars_repo_name: lanl/generalized-spallation-model

max_stars_repo_licenses: Intel Unlicense

max_issues_repo_name: lanl/generalized-spallation-model

max_issues_repo_licenses: Intel Unlicense

max_forks_repo_name: lanl/generalized-spallation-model

max_forks_repo_licenses: Intel Unlicense


!======================================================================
!         Z C B
!======================================================================

      REAL(KIND(0.0D0)) FUNCTION ZCB (K1, K2, K3)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
!...Translated by Pacific-Sierra Research 77to90  4.3E  21:52:17  11/14/01
!...Switches:
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER , INTENT(IN) :: K1
      INTEGER , INTENT(IN) :: K2
      INTEGER , INTENT(IN) :: K3
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: M, N, N1, N2, N3, M1, M2, M3, I, K, IK, J
      REAL(DOUBLE) :: A, B
!-----------------------------------------------
!
!     CB =  3j(k1,0,k2,0,k3,0)**2
!
!
      ZCB = 0.0
!
      M = K1 + K2 + K3
      N = M/2
      IF (N + N /= M) RETURN
      M = M + 1
!
      N1 = N - K1
      N2 = N - K2
      N3 = N - K3
      IF (N1<0 .OR. N2<0 .OR. N3<0) RETURN
      M1 = N1 + N1
      M2 = N2 + N2
      M3 = N3 + N3
!
      A = 1.0
!
      DO I = 2, M
         K = -1                                  ! the extent of integer I in units of 1/2
         IF (M1 >= I) K = K + 1
         IF (M2 >= I) K = K + 1
         IF (M3 >= I) K = K + 1
         IF (N >= I) K = K + 2
         IF (N1 >= I) K = K - 2
         IF (N2 >= I) K = K - 2
         IF (N3 >= I) K = K - 2
!
         IK = IABS(K)
         B = DBLE(I)
         IF (K > 0) THEN
            DO J = 1, IK
               A = A*B
            END DO
         ENDIF
         IF (K >= 0) CYCLE
         DO J = 1, IK
            A = A/B
         END DO
!
      END DO
!
      ZCB = A
      RETURN
      END FUNCTION ZCB


text:
Address(Rialto Lane) is a residential loop street in South Davis.

 Intersecting Streets

  Montgomery Avenue
  Montgomery Avenue again

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


! { dg-do run }
!
! Test the fix for PR83898.f90
!
! Contributed by G Steinmetz  <gscfq@t-online.de>
!
program p
   associate (x => ['1','2'])
      if (any (x .ne. ['1','2'])) STOP 1
   end associate
end


text:
	SUBROUTINE GGTOI  ( np, xg, yg, xm, ym, iret )
C************************************************************************
C* GGTOI								*
C*									*
C* This subroutine converts points in the grid coordinate system into	*
C* values in the grid linear intermediate coordinate system.		*
C*									*
C* GGTOI  ( NP, XG, YG, XM, YM, IRET )					*
C*									*
C* Input parameters:							*
C*	NP		INTEGER		Number of points		*
C*	XG (NP)		REAL		X input coordinates		*
C*	YG (NP)		REAL		Y input coordinates		*
C*									*
C* Output parameters:							*
C*	XM (NP)		REAL		X output coordinates		*
C*	YM (NP)		REAL		Y output coordinates		*
C*	IRET		INTEGER		Return code			*
C**									*
C* Log:									*
C* M. desJardins/GSFC	 6/85	GEMPLT Version 3.1			*
C* M. desJardins/GSFC	10/86	Added polar coordinates			*
C* M. desJardins/GSFC	 2/87	Fixed polar coords when graph not set	*
C* M. desJardins/GSFC	 1/88	Fixed missing data			*
C* M. desJardins/GSFC	 6/88	Adapted from GGTOM			*
C************************************************************************
	INCLUDE		'ERROR.PRM'
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'XYDEF.CMN'
C*
	REAL		xg (*), yg (*), xm (*), ym (*)
C*
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
C*	Transform grid to linear intermediate coordinates for map mode.
C
	IF  ( igmode .eq. 1 )  THEN
C*
	    IF  ( .not. mgset )  THEN
		iret = NIPROJ
		RETURN
	    END IF
C*
	    iret = NORMAL
	    DO  i = 1, np
		IF  ( ( .not. ERMISS ( xg (i) ) ) .and.
     +		      ( .not. ERMISS ( yg (i) ) ) )  THEN
		    xm (i) = aglx1 * xg (i) + aglx0
		    ym (i) = agly1 * yg (i) + agly0
		  ELSE
		    xm (i) = RMISSD
		    ym (i) = RMISSD
		END IF
	    END DO
C
C*	    Convert to linear coordinates for graph mode.
C
	  ELSE IF  ( igmode .eq. 2 )  THEN
C*
	    IF  ( .not. ggset )  THEN
		iret = NIPROJ
		RETURN
	    END IF
C*
	    iret = NORMAL
	    DO  i = 1, np
		IF  ( ( .not. ERMISS ( xg (i) ) ) .and.
     +		      ( .not. ERMISS ( yg (i) ) ) )  THEN
		    xm (i) = gxx1 * xg (i) + gxx0
		    ym (i) = gyy1 * yg (i) + gyy0
		  ELSE
		    xm (i) = RMISSD
		    ym (i) = RMISSD
		END IF
	    END DO
	END IF
C*
	RETURN
	END


text:
      double precision VV(-nf:nf,-nf:nf),gl(-nf:nf,-nf:nf),
     & gr(-nf:nf,-nf:nf),e(-nf:nf,-nf:nf),fl,fr
      double precision glsq(-nf:nf,-nf:nf),grsq(-nf:nf,-nf:nf),
     & flsq,frsq
      common/CKM1/VV,gl,gr,fl,fr,e,glsq,grsq,flsq,frsq

max_stars_repo_name: tmartini/JHUGen

max_issues_repo_name: tmartini/JHUGen

max_forks_repo_name: tmartini/JHUGen


text:
! ###################################################################
! Copyright (c) 2013-2020, Marc De Graef Research Group/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:EMAverageOrient.f90
!--------------------------------------------------------------------------
!
! PROGRAM: EMAverageOrient
!
!> @author Marc De Graef, Carnegie Mellon University
!
!> @brief create a ctf file with averaged orientations based on a dot product output file
!
!> @date 06/24/16 MDG 1.0 original
!> @date 07/06/16 MDG 1.1 replaced computation with call to EBSDgetAverageOrientations
!> @date 03/12/18 MDG 1.2 replaced reading of dot product file by new subroutine
!--------------------------------------------------------------------------
program EMAverageOrient

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 rotations
use Lambert
use quaternions
use stringconstants
use commonmod

IMPLICIT NONE

character(fnlen)                        :: nmldeffile, progname, progdesc
type(AverageOrientationNameListType)    :: enl
type(EBSDIndexingNameListType)          :: ebsdnl
type(EBSDDIdataType)                    :: EBSDDIdata

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
character(fnlen)                        :: groupname, dataset, dpfile, energyfile, masterfile, efile, fname
integer(HSIZE_T)                        :: dims2(2),dims(1),dims2D(2)
real(kind=sgl)                          :: q1(4), q2(4), qus(4), a, oldmo, p(4), qsmall(4), theta, vec(3)
type(dicttype)                          :: dict

character(fnlen),allocatable            :: stringarray(:)
real(kind=sgl),allocatable              :: Eulers(:,:), dplist(:,:), Eulerstmp(:,:), dplisttmp(:,:), avEuler(:,:), &
                                           resultmain(:,:), disor(:), disorient(:,:), OSMmap(:,:), IQmap(:), ADMap(:,:)
integer(kind=irg),allocatable           :: tmi(:,:), tmitmp(:,:), indexmain(:,:)

type(HDFobjectStackType)                :: HDF_head

nullify(HDF_head%next)

nmldeffile = 'EMAverageOrient.nml'
progname = 'EMAverageOrient.f90'
progdesc = 'Generate a ctf file with averaged orientations'

! print some information
call EMsoft(progname, progdesc)

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

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

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

! open the fortran HDF interface
call h5open_EMsoft(hdferr)

if (enl%refined.eq.'n') then
  call readEBSDDotProductFile(enl%dotproductfile, ebsdnl, hdferr, EBSDDIdata, &
                              getOSM=.TRUE., &
                              getIQ=.TRUE., &
                              getEulerAngles=.TRUE., &
                              getTopDotProductList=.TRUE., &
                              getTopMatchIndices=.TRUE.)
else
  call readEBSDDotProductFile(enl%dotproductfile, ebsdnl, hdferr, EBSDDIdata, &
                              getOSM=.TRUE., &
                              getIQ=.TRUE., &
                              getRefinedEulerAngles=.TRUE.)
end if

Nexp = EBSDDIdata%Nexp
FZcnt = EBSDDIdata%FZcnt
dims2(1) = ebsdnl%nnk
if (enl%refined.eq.'n') then
  allocate(Eulers(3,FZcnt))
  do i=1,FZcnt
    Eulers(1:3,i) = EBSDDIdata%EulerAngles(1:3,i)
  end do
  deallocate(EBSDDIdata%EulerAngles)
  Eulers = Eulers * sngl(cPi)/180.0

  allocate(dplist(dims2(1),Nexp))
  do i=1,Nexp
    dplist(1:dims2(1),i) = EBSDDIdata%TopDotProductList(1:dims2(1),i)
  end do
  deallocate(EBSDDIdata%TopDotProductList)
  nnm = dims2(1)

  allocate(tmi(nnm,Nexp))
  do i=1,Nexp
    tmi(1:nnm,i) = EBSDDIdata%TopMatchIndices(1:nnm,i)
  end do
  deallocate(EBSDDIdata%TopMatchIndices)
else
  allocate(Eulers(3,Nexp))
  do i=1,Nexp
    Eulers(1:3,i) = EBSDDIdata%RefinedEulerAngles(1:3,i)
  end do
  deallocate(EBSDDIdata%RefinedEulerAngles)
end if

! the following arrays are kept in the EBSDDIdata structure
!   OSMmap = EBSDDIdata%OSM
!   IQmap = EBSDDIdata%IQ

call Message('  --> dot product EBSD HDF5 file read')

if (enl%refined.eq.'n') then
!===================================
! we will also need some of the crystallographic data, so that requires
! extracting the xtalname from the energyfile
write (*,*) 'energyfile = ', trim(ebsdnl%energyfile)
  efile = trim(EMsoft_getEMdatapathname())//trim(ebsdnl%energyfile)
  efile = EMsoft_toNativePath(efile)
write (*,*) 'efile = ', trim(efile)

! first, we need to check whether or not the input file is of the HDF5 format type; if
! it is, we read it accordingly, otherwise we use the old binary format.
!
  call h5fis_hdf5_f(efile, stat, hdferr)

  if (stat) then
  ! open the fortran HDF interface
    call h5open_EMsoft(hdferr)

    nullify(HDF_head%next)

  ! open the MC file using the default properties.
    readonly = .TRUE.
    hdferr =  HDF_openFile(efile, HDF_head, readonly)

  ! open the namelist group
    groupname = SC_NMLparameters
      hdferr = HDF_openGroup(groupname, HDF_head)
    groupname = SC_MCCLNameList
      hdferr = HDF_openGroup(groupname, HDF_head)

  ! read all the necessary variables from the namelist group
    dataset = SC_xtalname
      call HDF_readDatasetStringArray(dataset, nlines, HDF_head, hdferr, stringarray)
      ebsdnl%MCxtalname = trim(stringarray(1))
      deallocate(stringarray)

write (*,*) 'xtalname  = ', ebsdnl%MCxtalname

! dataset = SC_EkeV
!   call HDF_readDatasetDouble(dataset, HDF_head, hdferr, ebsdnl%EkeV)

! dataset = SC_sig
!   call HDF_readDatasetDouble(dataset, HDF_head, hdferr, ebsdnl%MCsig)

    call HDF_pop(HDF_head,.TRUE.)

! close the fortran HDF interface
    call h5close_EMsoft(hdferr)
  end if

! do the actual orientational averaging
  allocate(avEuler(3,Nexp),disorient(Nexp,enl%nmuse))
  ipar2(1) = EBSDDIdata%pgnum
  ipar2(2) = FZcnt
  ipar2(3) = Nexp
  ipar2(4) = ebsdnl%nnk
  ipar2(5) = Nexp*ceiling(float(ebsdnl%ipf_wd*ebsdnl%ipf_ht)/float(Nexp))
  ipar2(6) = enl%nmuse
  call EBSDgetAverageOrientations(ipar2, Eulers, tmi, dplist, avEuler, disorient)

  ! ok, so we have our list; next we need to store this in a ctf file, along with
  ! all the other crystallographic information, so we need to fill in the proper
  ! fields in the ebsdnl structure and ipar array.
  ipar = 0
  ipar(1) = 1
  ipar(2) = Nexp
  ipar(3) = Nexp
  ipar(4) = Nexp
  ipar(5) = FZcnt
  ipar(6) = EBSDDIdata%pgnum
  ipar(7) = ebsdnl%ipf_wd
  ipar(8) = ebsdnl%ipf_ht
  ebsdnl%ctffile = enl%averagectffile

  allocate(indexmain(1,Nexp), resultmain(1,Nexp))
  indexmain = 0
  resultmain(1,1:Nexp) = dplist(1,1:Nexp)
  noindex = .TRUE.
  call h5open_EMsoft(hdferr)
  call ctfebsd_writeFile(ebsdnl,ebsdnl%MCxtalname,ipar,indexmain,avEuler,resultmain,EBSDDIdata%OSM,EBSDDIdata%IQ,noindex)
  call h5close_EMsoft(hdferr)
  call Message('Data stored in ctf file : '//trim(enl%averagectffile))
end if

! do we need to produce a relative disorientation map ?
if (trim(enl%disorientationmap).ne.'undefined') then
!===================================
! set up the symmetry quaternions for this rotational symmetry
! allocate the dict structure
  dict%Num_of_init = 3
  dict%Num_of_iterations = 30
  dict%pgnum = EBSDDIdata%pgnum
! initialize the symmetry matrices
  call DI_Init(dict,'nil')

  if (enl%refined.eq.'n') then
! put the Euler angles back in radians
    avEuler = avEuler * sngl(cPi)/180.0
! get the 1D point coordinate
    ipat = ebsdnl%ipf_wd * enl%reldisy + enl%reldisx
    allocate(disor(Nexp))
! and get the disorientations w.r.t. all the others
    do j=1,Nexp
      call getDisorientationAngle(avEuler(1:3,ipat),avEuler(1:3,j),dict,oldmo)
      disor(j) = oldmo
    end do
    disor = disor*180.0/sngl(cPi)
else
! get the 1D point coordinate
    ipat = ebsdnl%ipf_wd * enl%reldisy + enl%reldisx
    allocate(disor(Nexp))
! and get the disorientations w.r.t. all the others
    do j=1,Nexp
      call getDisorientationAngle(Eulers(1:3,ipat),Eulers(1:3,j),dict,oldmo)
      disor(j) = oldmo
    end do
    disor = disor*180.0/sngl(cPi)

! next, we compute the average disorientation map (ADM) by computing the disorientations between each
! point and its four neighbors and averaging them.
    ! allocate (ADMap(ebsdnl%ipf_wd, ebsdnl%ipf_ht))
    ! call getAverageDisorientationMap(Eulers, dict, ebsdnl%ipf_wd, ebsdnl%ipf_ht, ADMap)
    ! open(unit=dataunit,file='ADMap.data',status='unknown',form='unformatted')
    ! write (dataunit) ebsdnl%ipf_wd, ebsdnl%ipf_ht
    ! write(dataunit) ADMap
    ! close(unit=dataunit,status='keep')
end if

! for now, we export the data in a simple text file; this needs to be modified in the future.
  open(unit=dataunit,file=trim(EMsoft_getEMdatapathname())//trim(enl%disorientationmap),status='unknown',form='formatted')
  write (dataunit,"(3I10)") Nexp, ebsdnl%ipf_wd, ebsdnl%ipf_ht
  do i=1,Nexp
    write(dataunit,"(F13.6)") disor(i)
  end do
  close(unit=dataunit,status='keep')
end if

end program EMAverageOrient

max_stars_repo_name: hwagit/EMsoft

max_stars_repo_licenses: Intel BSD-3-Clause MIT-CMU Unlicense

max_issues_repo_name: hwagit/EMsoft

max_issues_repo_licenses: Intel BSD-3-Clause MIT-CMU Unlicense

max_forks_repo_name: hwagit/EMsoft

max_forks_repo_licenses: Intel BSD-3-Clause MIT-CMU Unlicense


text:
!      INTEGER N, iters
!      REAL check

!      N = 128
!      iters = N*3
!      CALL echo_f77(N,iters,check)
!      PRINT *, check
!      END

      SUBROUTINE echo_f77(N, niters, check)
      INTEGER N, niters, iter
      REAL check
      REAL P1(N,N), P2(N,N), P3(N,N), C(N,N)
      INTEGER i, j

      CALL echo_f77_set(c, P1, P2, P3, N)
      CALL checkArray(P2, N)
      CALL checkArray(c, N)

      DO iter=1, niters
        DO j=2,N-1
          DO i=2,N-1
            P3(i,j) = (2-4*c(i,j))*P2(i,j) + c(i,j)*(P2(i,j-1)
     .          + P2(i,j+1) + P2(i-1,j) + P2(i+1,j)) - P1(i,j)
          END DO
        END DO

        DO j=1,N
          DO i=1,N
            P1(i,j) = P2(i,j)
            P2(i,j) = P3(i,j)
          END DO
        END DO
      END DO

      check = P1(N/2,7*N/8)

      RETURN
      END

      SUBROUTINE echo_f77_set(c, P1, P2, P3, N)
      INTEGER N
      REAL c(N,N), P1(N,N), P2(N,N), P3(N,N)

      INTEGER i, j, blockLeft, blockRight, blockTop, blockBottom
      INTEGER channelLeft, channelRight, channel1Height, channel2Height
      INTEGER cr, cc
      REAL s2

!     Default velocity in the air

      DO j=1,N
        DO i=1,N
          c(i,j) = 0.2
        END DO
      END DO

!     Solid block with which the pulse collids

      blockLeft = 1
      blockRight = 2 * N / 5.0
      blockTop = N / 3.0
      blockBottom = 2 * N / 3.0

      DO j=blockLeft,blockRight
        DO i=blockTop,blockBottom
          c(i,j) = 0.5
        END DO
      END DO

!     Channel directing the pulse leftwards

      channelLeft = 4 * N / 5.0
      channelRight = N
      channel1Height = 3 * N / 8.0
      channel2Height = 5 * N / 8.0

      DO j = channelLeft,channelRight
        c(channel1Height,j) = 0.0
        c(channel2Height,j) = 0.0
      END DO

!     Initial pressure distribution: a gaussian pulse inside the channel

      cr = N / 2
      cc = 7 * N / 8.0
      s2 = 64.0 * 9.0 / ((N/2.0) ** 2)

      print *, 'cr = ', cr, ' cc = ', cc, ' s2 = ', s2

      DO j=1,N
        DO i=1,N
          P1(i,j) = 0.0
          P2(i,j) = exp(-((i-cr)**2 + (j-cc)**2) * s2)
          P3(i,j) = 0.0
        END DO
      END DO

      RETURN
      END

      SUBROUTINE checkArray(A, N)
      INTEGER N
      REAL A(N,N)

      INTEGER i,j
      REAL check
      check = 0.0
      DO j=1,N
        DO i=1,N
          check = check + (i*n+j)*A(i,j)
        END DO
      END DO

      PRINT *, 'Array check: ', check
      RETURN
      END

max_stars_repo_name: fraguela/depspawn

max_issues_repo_name: MSV-Project/IBAMR

max_forks_repo_name: MSV-Project/IBAMR


program use
use foo
implicit none
integer tata
toto = 4
tata = 5
end program use


text:
           program demo_btest
           implicit none
           integer :: i = 32768 + 1024 + 64
           integer :: pos
           logical :: bool
               do pos=0,16
                   bool = btest(i, pos)
                   print *, pos, bool
               end do
           end program demo_btest

max_stars_repo_name: urbanjost/fortran-intrinsic-manpages

max_issues_repo_name: urbanjost/fortran-intrinsic-manpages

max_forks_repo_name: urbanjost/fortran-intrinsic-manpages


text:
       integer function u2ipth(iuser)
c
c//////////////////////////////////////////////////////////////////////
c Copyright (c) 1997--2000 Matthew Newville, The University of Chicago
c Copyright (c) 1992--1996 Matthew Newville, University of Washington
c
c Permission to use and redistribute the source code or binary forms of
c this software and its documentation, with or without modification is
c hereby granted provided that the above notice of copyright, these
c terms of use, and the disclaimer of warranty below appear in the
c source code and documentation, and that none of the names of The
c University of Chicago, The University of Washington, or the authors
c appear in advertising or endorsement of works derived from this
c software without specific prior written permission from all parties.
c
c THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
c EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
c MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
c IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
c CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
c TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
c SOFTWARE OR THE USE OR OTHER DEALINGS IN THIS SOFTWARE.
c//////////////////////////////////////////////////////////////////////
c
c return ifeffit's "internal path index" given a user path and dataset
       implicit none
       include 'consts.h'
       include 'pthpar.h'
       save
       integer  i, iuser
       u2ipth = 0
c find i such that    iuser  = jdtusr(i)
c and then            inpath = jdtpth(i)
c note that i can be zero!!
       do 10 i = 0, mpaths
          if (iuser .eq. jdtusr(i)) then
             u2ipth   =  jdtpth(i)
             return
          end if
 10    continue
       return
       end

max_stars_repo_name: keechul/ifeffit

max_stars_repo_licenses: Naumen Condor-1.1 MS-PL

max_issues_repo_name: bruceravel/ifeffit

max_issues_repo_licenses: Naumen Condor-1.1 MS-PL

max_forks_repo_name: bruceravel/ifeffit

max_forks_repo_licenses: Naumen Condor-1.1 MS-PL


      subroutine cal_parmchg_read

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this function computes new paramter value based on
!!    user defined change

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    val_cur     |variable      |current parameter value
!!                               |the standard temperature (20 degrees C)
!!    chg         |data type     |contains information on variable change
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    chg_par     |variable      |new parameter value
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use input_file_module
      use maximum_data_module
      use calibration_data_module
      use hydrograph_module

      implicit none

      !integer, dimension (:), allocatable :: elem_cnt1   !           |
      character (len=80) :: titldum                       !           |title of file
      character (len=80) :: header                        !           |header of file
      integer :: eof                                      !           |end of file
      integer :: imax                                     !none       |determine max number for array (imax) and total number in file
      integer :: nspu                                     !           |
      logical :: i_exist                                  !none       |check to determine if file exists
      integer :: i                                        !none       |counter
      integer :: ie                                       !none       |counter
      integer :: mcal                                     !           |
      integer :: isp                                      !none       |counter
      integer :: ical                                     !none       |counter
      integer :: ipar                                     !           |
      integer :: ielem1                                   !none       |counter
      integer :: nconds                                   !none       |counter
      integer :: icond                                    !none       |counter

      imax = 0
      mcal = 0

      !!read parameter change values for calibration
      inquire (file=in_chg%cal_upd, exist=i_exist)
      if (.not. i_exist .or. in_chg%cal_upd == "null") then
        allocate (cal_upd(0:0))
      else
      do
        open (107,file=in_chg%cal_upd)
        read (107,*,iostat=eof) titldum
        if (eof < 0) exit
        read (107,*,iostat=eof) mcal
        allocate (cal_upd(mcal))
        if (eof < 0) exit
        read (107,*,iostat=eof) header
        if (eof < 0) exit

      do i = 1, mcal

        read (107,*,iostat=eof) cal_upd(i)%name, cal_upd(i)%chg_typ, cal_upd(i)%val, cal_upd(i)%conds,      &
              cal_upd(i)%lyr1, cal_upd(i)%lyr2, cal_upd(i)%year1, cal_upd(i)%year2, cal_upd(i)%day1,        &
              cal_upd(i)%day2, nspu
        if (eof < 0) exit
        if (nspu > 0) then
          backspace (107)
          allocate (elem_cnt(nspu))
          read (107,*,iostat=eof) cal_upd(i)%name, cal_upd(i)%chg_typ, cal_upd(i)%val, cal_upd(i)%conds,    &
              cal_upd(i)%lyr1, cal_upd(i)%lyr2, cal_upd(i)%year1, cal_upd(i)%year2, cal_upd(i)%day1,        &
              cal_upd(i)%day2, cal_upd(i)%num_tot, (elem_cnt(isp), isp = 1, nspu)
          if (eof < 0) exit
        end if

          !! crosswalk name with calibration parameter db
          do ical = 1, db_mx%cal_parms
            if (cal_upd(i)%name == cal_parms(ical)%name) then
              cal_upd(i)%num_db = ical
              exit
            end if
          end do

          !! allocate and read the conditions
          nconds = cal_upd(i)%conds
          if (nconds > 0) then
            allocate (cal_upd(i)%cond(nconds))
            do icond = 1, nconds
              read (107,*,iostat=eof) cal_upd(i)%cond(icond)
            end do
          end if

          !!if no objects are specified - check all of them
          if (cal_upd(i)%num_tot == 0) then
            ipar = cal_upd(i)%num_db
            select case (cal_parms(ipar)%ob_typ)
            case ("hru")
              cal_upd(i)%num_elem = sp_ob%hru
            case ("lyr")
              cal_upd(i)%num_elem = sp_ob%hru
            case ("sol")
              cal_upd(i)%num_elem = sp_ob%hru
            case ("hlt")
              cal_upd(i)%num_elem = sp_ob%hru_lte
            case ("ru")
              cal_upd(i)%num_elem = sp_ob%ru
            case ("gw")
              cal_upd(i)%num_elem = sp_ob%aqu
            case ("rte")
              cal_upd(i)%num_elem = sp_ob%chan
            case ("swq")
              cal_upd(i)%num_elem = sp_ob%chan
            case ("res")
              cal_upd(i)%num_elem = sp_ob%res
            case ("sdc")
              cal_upd(i)%num_elem = sp_ob%chandeg
            case ("bsn")
              cal_upd(i)%num_elem = 1
            case ("pcp")
              cal_upd(i)%num_elem = db_mx%pcpfiles
            case ("tmp")
              cal_upd(i)%num_elem = db_mx%tmpfiles
            end select

            allocate (cal_upd(i)%num(cal_upd(i)%num_elem))
            do ie = 1, cal_upd(i)%num_elem
                cal_upd(i)%num(ie) = ie
            end do
          else

            call define_unit_elements (nspu, ielem1)
            allocate (cal_upd(i)%num(ielem1))
            cal_upd(i)%num = defunit_num
            cal_upd(i)%num_elem = ielem1
            deallocate (defunit_num)

          end if
        end do
        exit

      end do
      end if

      db_mx%cal_upd = mcal

      return
      end subroutine cal_parmchg_read


text:
module step_functions

contains

pure function step (f, d)
   ! Smoothed step function (=0 for F<=-D, =1 for F>>D)
   ! D is the smoothing length
   use real_kind
   implicit none
   real(double), intent(in) :: f, d
   real(double) :: step
   step = smf (1, f, d)
end function step

pure function pstv (f, d)
   ! Smoothed triangle function (=0 for F<=-D, =F for F>>D)
   ! D is the smoothing length
   use real_kind
   implicit none
   real(double), intent(in) :: f, d
   real(double) :: pstv
   pstv = smf (2, f, d)
end function pstv

pure function smf (iht, f, d)
   ! Smoothed step function (IHT=1) or triangle function (IHT=2)
   use real_kind
   implicit none
   real(double), intent(in) :: f, d
   integer, intent(in) :: iht
   real(double) :: smf
   real(double) :: x, y
   x = f + d
   if ( x.le.1.0d-150 ) then  ! Make sure that X**2>0 numerically
      smf = 0.0d0
   else
      if(x < 1.d130) then    ! safety net for big numbers !SdM
         y = x*x             ! moved to location where it is needed !SdM
         smf = y/(d*d + y)
      else
         smf = 1.d0
      end if
   end if
   if ( iht == 2 ) smf = x*smf
end function smf

end module step_functions

max_stars_repo_name: rknop/amuse

max_issues_repo_name: rknop/amuse

max_forks_repo_name: rieder/amuse


        !COMPILER-GENERATED INTERFACE MODULE: Fri Mar  6 15:34:54 2020
        ! This source file is for reference only and may not completely
        ! represent the generated interface used by the compiler.
        MODULE LUDCMP__genmod
          INTERFACE
            SUBROUTINE LUDCMP(A,N,INDX)
              INTEGER(KIND=4) :: N
              REAL(KIND=8) :: A(N,N)
              INTEGER(KIND=4) :: INDX(N)
            END SUBROUTINE LUDCMP
          END INTERFACE
        END MODULE LUDCMP__genmod


text:
! Copyright (c) 2018, NVIDIA CORPORATION.  All rights reserved.
!
! 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.

! Test pointer to contiguous array section is passed correctly for
! assumed-shape dummy argument.
module fs25090
  implicit none
  logical :: failed = .false.

contains

  subroutine sub1(l, m, n, nn)
    integer, intent(in) :: l, m, n, nn
    integer :: i, j, k
    integer(8) :: expected, actual
    integer(8), pointer, contiguous :: p(:,:)
    integer(8), pointer :: matrix(:,:,:)
    ! initialize matrix
    allocate(matrix(l, m, n))
    do i = 1, l
      do j = 1, m
        do k = 1, n
          matrix(i, j, k) = 100*l + 10*m + n
        end do
      end do
    end do
    p => matrix(:,:,nn)
    call sub2(p)
    ! check matrix
    do i = 1, l
      do j = 1, m
        do k = 1, n
          expected = 100*l + 10*m + n
          if (k .eq. nn) expected = -expected
          actual = matrix(i, j, k)
          if (expected .ne. actual) then
            write(*,'("FAIL at",3i3,": expected=",i5," actual=",i5)') i, j, k, expected, actual
            failed = .true.
          end if
        end do
      end do
    end do
  end subroutine

  subroutine sub2(x)
    integer(8) :: x(:,:)
    integer(8) :: i, j
    do i = lbound(x, 1), ubound(x, 1)
      do j = lbound(x, 2), ubound(x, 2)
        x(i, j) = -x(i, j)
      end do
    end do
  end subroutine

end module

use fs25090
call sub1(3, 3, 3, 2)
call sub1(2, 3, 4, 4)
if (.not. failed) write(*,'("PASS")')
end

max_stars_repo_name: kammerdienerb/flang

max_issues_repo_name: kammerdienerb/flang

max_forks_repo_name: kammerdienerb/flang


text:
!
!*********************************************************************************
!** Compute conductivity **
!*********************************************************************************
!
!
 program Transport
  use PrecisionMod
  use MathConstantsMod
  use ParallelMod
  use LibMod
  use InputMod
  use KpointsMod
  use HamiltonianMod
  use CurrentVertexMod
  use SelfEnMod
  use OpticMod
  implicit none
!
  include 'mpif.h'
!
  character(len=2) :: indx1
  character(len=3) :: indx2
  character(len=4) :: indx4
  character(len=22) :: form
  character(len=100) :: FileName
  integer(i4b) :: nk, kindex, ns, nw, Niwn, Nipn, Nivn, Nv, error, Nsize, n, m
  integer(i4b) :: Norb1, Norb2, Norb3, Norb4, orbindex1, orbindex2
  integer(i4b) :: i, j, ii, jj
  real(dp) :: Omega_n
  complex(dpc), dimension(:,:,:,:), allocatable :: Hamk
  complex(dpc), dimension(:,:,:,:), allocatable :: SelfEn
  complex(dpc), dimension(:,:,:,:,:), allocatable :: BareVertex
!
  integer(i4b), dimension(2) :: dir
  real(dp), dimension(:), allocatable :: val, val2
  complex(dpc), dimension(:), allocatable :: vec1, vec2
  complex(dpc), dimension(:,:), allocatable :: mat, identity
  complex(dpc), dimension(:,:,:,:), allocatable :: LocalGFn, LocGFn
  complex(dpc), dimension(:,:), allocatable :: GFn
  real(dp), dimension(:,:,:), allocatable :: Sigma, Sigma1, Sigma2
  complex(dpc), dimension(:,:,:), allocatable :: Pol, Pol1, Pol2
  complex(dpc), dimension(:,:), allocatable :: Polarization
!
!--variable for parallel run
  integer(i4b) :: anid, ierr, isender, numsent
  integer(i4b), parameter :: senddatatag = 2013
  integer(i4b), parameter :: returndatatag = 2014
  integer(i4b), dimension(MPI_STATUS_SIZE) :: status
!
  real(dp) :: starttime, endtime
!
  call InitParallel
!
  call walltime (starttime)
!
  if(MYID.eq.0 .and. NPE.gt.1) then
    write(*,'(/,a,i5,a11)') ' MPI-parallel calculation using ', NPE, ' processors'
  endif
!
!******************************
!** Read system's parameters **
!******************************
!
  write(*,'(/,a15,2x,i4)') 'Reading Inputs:', Myid
  call InputInit()
!
!
!****************************
!** reading the input data **
!****************************
!
  write(*,'(/,a17,2x,i4)') 'Reading K-points:', Myid
  call KpointsInit(casename)
!
  allocate(Hamk( Numorbitals, Numorbitals, NumIrKpoints,NumSpin), stat=error)
  if(error .ne. 0) stop 'Main: error allocating Hamk'
  allocate(BareVertex(3, Numorbitals, Numorbitals, NumIrKpoints, NumSpin), stat=error)
  if(error .ne. 0) stop 'Main: error allocating BareVertex'
!
  allocate(SelfEn(Numorbitals, Numorbitals, 0:NiwnMax, NumSpin), stat=error)
    if(error .ne. 0) stop 'Main: error allocating SelfEn'
!
! read Ham(k)
  write(*,'(a8,2x,i4)') 'Read Hk:', Myid
  call HkInit(casename, Numspin, Numorbitals, numIrkpoints, Hamk)
!
! Read Bare current vertices
  write(*,'(a8,2x,i4)') 'Read vk:', Myid
  call BareCurrentVertexInit(casename, Numspin, Numorbitals, NumIrkpoints, BareVertex)
!
! Read Self energy
  SelfEn = (0.0_dp,0.0_dp)
  if (InteractingSystem) then
    write(*,'(a12,2x,i4)') 'Read SelfEn:', Myid
    call SelfEnInit2(casename, Numspin, Numorbitals, Niwnmax, InverseTemperature, SelfEn)
  end if
!
  call barrier()
!
!---------------
!-- Local GFn --
!---------------
!
  write(*,'(a20,2x,i4)') 'calculate Local GFn:', Myid
  allocate(Identity(NumOrbitals,NumOrbitals), stat= error)
  if (error .ne. 0) stop 'Main: unable to allocate mat'
  Identity = (zero,zero)
  do Norb1=1, NumOrbitals
    Identity(Norb1,Norb1) = (one,zero)
  end do
!
    if (Myid .eq. 0) then
      allocate(LocalGFn(NumOrbitals, NumOrbitals, 0:NiwnMax, NumSpin), GFn(NumOrbitals, NumOrbitals), stat= error)
      if (error .ne. 0) stop 'Main: unable to allocate GFn'
      LocalGFn = (zero,zero)
      do ns = 1, NumSpin
        do Niwn = 0, NiwnMax
          Omega_n = (two*Niwn+one)*pi_d/InverseTemperature
          nk = 0
          do kindex = startkp(Myid), endkp(Myid)
            nk = nk+1
            GFn = (xi*Omega_n+ ChemicalPotential)*Identity-Hamk(:,:,kindex,ns)-SelfEn(:,:,niwn,ns)
            call InverseUsingLapack(GFn)
!
            LocalGFn(:,:,niwn,ns) = LocalGFn(:,:,Niwn,ns) + GFn(:,:)/NumIrkpoints
          end do
        end do
      end do
!     recive LocalGFn from computing nodes
      if(NPE .gt. 1) then
        allocate(LocGFn(NumOrbitals, NumOrbitals, 0:NiwnMax, NumSpin), stat= error)
        if (error .ne. 0) stop 'Main: unable to allocate LocGFn'
        Nsize = (NumOrbitals**2)*(NiwnMax+1)*NumSpin
        do Anid =1, NPE-1
          call MPI_RECV(LocGFn, Nsize, MPI_DOUBLE_COMPLEX, MPI_ANY_SOURCE, MPI_ANY_TAG, comm, status, ierr)
          isender = status(MPI_SOURCE)
          LocalGFn = LocalGFn + LocGFn
        end do
	deallocate(LocGFn, stat= error)
        if (error .ne. 0) stop 'Main: unable to allocate LocGFn'
      end if
!     write LocalGFn
      filename = 'GFniwn.dat'
      open(100,file=trim(FileName), status='unknown')
      write(indx2,'(i3.3)') 2*NumSpin*(NumOrbitals**2)
      form = '(f16.10,'//indx2//'f24.16)'
      do Niwn = 0, NiwnMax
        Omega_n = (two*Niwn+one)*pi_d/InverseTemperature
        write(100,form) Omega_n,  (((LocalGFn(Norb1,Norb2,niwn,ns),Norb2=1,NumOrbitals),Norb1=1,NumOrbitals),ns=1,NumSpin)
      end do
      close(100)
      deallocate(LocalGFn, GFn, stat= error)
      if (error .ne. 0) stop 'Main: unable to allocate GFn'
    else  ! computing node
      allocate(LocalGFn(NumOrbitals, NumOrbitals, 0:NiwnMax, NumSpin), GFn(NumOrbitals, NumOrbitals), stat= error)
      if (error .ne. 0) stop 'Main: unable to allocate GFn'
      LocalGFn = (zero,zero)
      do ns = 1, NumSpin
        do Niwn = 0, NiwnMax
          Omega_n = (two*Niwn+one)*pi_d/InverseTemperature
          nk = 0
          do kindex = startkp(Myid), endkp(Myid)
            nk = nk+1
            GFn = (xi*Omega_n+ ChemicalPotential)*Identity-Hamk(:,:,kindex,ns)-SelfEn(:,:,niwn,ns)
            call InverseUsingLapack(GFn)
!
            LocalGFn(:,:,niwn,ns) = LocalGFn(:,:,Niwn,ns) + GFn(:,:)/NumIrkpoints
          end do
        end do
      end do
!     send the LocalGFn to master node
      Nsize = (NumOrbitals**2)*(NiwnMax+1)*NumSpin
      call MPI_SEND(LocalGFn, Nsize, MPI_DOUBLE_COMPLEX, 0, Myid, comm, ierr)
      deallocate(LocalGFn, GFn, stat= error)
      if (error .ne. 0) stop 'Main: unable to allocate GFn'
    end if
!
!
  deallocate(Identity, stat= error)
  if (error .ne. 0) stop 'Main: unable to deallocate Identity'
!
  call barrier()
!
!
!*********************************************
!** Now actual calculation of the responses **
!*********************************************
!
!
  write(*,'(a19,2x,i4)') 'calculate response:', Myid
!
!-- Calculation of Polarization --
!
    if (MYId .eq. 0) then
!
        allocate( Pol(NivnMin:NivnMax, NumIrKpoints, NumSpin), Pol1(NivnMin:NivnMax, endkp(myid)-startkp(myid)+1,NumSpin), stat=error)
        if(error .ne. 0) stop 'Main: error allocating Pol'
        Pol = (zero,zero)
        Pol1 = (zero,zero)
        call OpticalPolarization (Nchoice, Numspin, NumOrbitals, numIrkpoints, NiwnMax, startkp(myid), endkp(myid), InverseTemperature, &
                                  ChemicalPotential, BareVertex, Hamk, SelfEn, NivnMin, NivnMax, Pol1)
        write(*,'(a8,2x,i4)') 'master: ', myid
        nk = 0
        do kindex = startkp(myid), endkp(myid)
          nk = nk + 1
          do nivn = NivnMin, NivnMax
            Pol(nivn,kindex,:) = Pol1(nivn, nk,:)
          end do
        end do
!
!-- recieving data from compute nodes --
!
        if(NPE .gt. 1) then
          allocate( Pol2(NivnMin:NivnMax, endkp(NPE-1)-startkp(NPE-1)+1,NumSpin), stat=error)
          if(error .ne. 0) stop 'Main: error allocating Pol2'
          Nsize = (NivnMax-NivnMin+1)*(endkp(NPE-1)-startkp(NPE-1)+1)*NumSpin
          do Anid =1, NPE-1
            Pol2 = (zero,zero)
            call MPI_RECV(Pol2, Nsize, MPI_DOUBLE_COMPLEX, MPI_ANY_SOURCE, MPI_ANY_TAG, comm, status, ierr)
            isender = status(MPI_SOURCE)
            write(*,'(a8,2x,i4)') 'Sender: ', isender
            nk = 0
            do kindex = startkp(isender), endkp(isender)
              nk = nk + 1
              do nivn = NivnMin, NivnMax
                Pol(nivn,kindex,:) = Pol2(nivn, nk,:)
              end do
            end do
          end do
	  deallocate( Pol2, stat=error)
          if(error .ne. 0) stop 'Main: error allocating Pol2'
        end if
        deallocate(Pol1, stat=error)
        if(error .ne. 0) stop 'Main: error deallocating Pol1'
!
    else         ! computing nodes
        allocate( Pol1(NivnMin:NivnMax, endkp(myid)-startkp(myid)+1,NumSpin), stat=error)
        if(error .ne. 0) stop 'Main: error allocating Pol1'
        Pol1 = (zero,zero)
        call OpticalPolarization (Nchoice, Numspin, NumOrbitals, numIrkpoints, NiwnMax, startkp(myid), endkp(myid), InverseTemperature, &
                                  ChemicalPotential, BareVertex, Hamk, SelfEn, NivnMin, NivnMax, Pol1)
!
!     send the Pol1 to master node
        Nsize =  (NivnMax-NivnMin+1)*(endkp(myid)-startkp(myid)+1)*NumSpin
        call MPI_SEND(Pol1, Nsize, MPI_DOUBLE_COMPLEX, 0, myid, comm, ierr)
!
        deallocate(Pol1, stat=error)
        if(error .ne. 0) stop 'Main: error deallocating Pol1'
    end if
!
!
!*****************************
!** Summation over k-points **
!*****************************
!
  if (MYId .eq. 0) then
        allocate( Polarization(NivnMin:NivnMax,NumSpin), stat=error)
        if(error .ne. 0) stop 'Main: error allocating Polarization'
        Polarization = (zero,zero)
!
        do nivn = NivnMin, NivnMax
          do nk = 1, NumIrKpoints
            Polarization(nivn,:) = Polarization(nivn,:) + Pol(nivn,nk,:)
          end do
        end do
        Polarization = Polarization/NumIrKpoints
!        if (NumSpin .eq. 1) Polarization = two*Polarization  ! counting for spin degeneracy
!
        fileName = 'OpticalPolarization.dat'
!
!     write Polarization
      open(100,file=trim(FileName), status='unknown')
        write(indx1,'(i2.2)') 2*NumSpin
        form = '(a32,'//indx1//'f24.16)'
!       Adding the diamagnetic term which is equal to -Paramagnetic term at v_n=0
        if (Nchoice .le. 3) write(100, form) '# diamagnetic contribution is : ', (Polarization(0,ns),ns=1,NumSpin)
        form = '(f16.10,'//indx1//'f24.16)'
        do nivn = NivnMin, NivnMax
          Omega_n = two*nivn*pi_d/InverseTemperature
          write(100,form) Omega_n, (Polarization(nivn,ns),ns=1,NumSpin)
        end do
!
        deallocate( Polarization, Pol, stat=error)
        if(error .ne. 0) stop 'Main: error deallocating Polarization'
      close(100)
!
  end if
!
!*****************
!** free memory **
!*****************
!
  deallocate(SelfEn, stat=error)
    if(error .ne. 0) stop 'Main: error deallocating SelfEn'
!
  deallocate(BareVertex, stat=error)
  if(error .ne. 0) stop 'Main: error deallocating BareVertex'
!
  deallocate(Hamk, stat=error)
  if(error .ne. 0) stop 'Main: error deallocating Hamk'
!
  call KpointsDestroy()
!
  call InputDestroy()
!
  call barrier()
!
  call walltime (endtime)
  if (myid .eq. 0) then
    print *, 'time is ', (endtime-starttime)/3600.0, ' hours'
  endif
!
  call CloseParallel
!
 end program Transport

max_stars_repo_name: RezaNourafkan/Transport-

max_issues_repo_name: RezaNourafkan/Transport-

max_forks_repo_name: RezaNourafkan/Transport-


      FUNCTION BESSHP (N,X)
      IMPLICIT NONE
      REAL *8 X
      COMPLEX *16 BESSHP,BESSH
      INTEGER N
      IF (N.EQ.0) THEN
        BESSHP=-BESSH(1,X)
      ELSE IF(X.EQ.0.D0) THEN
        X=1.D-30
      ELSE
        BESSHP=BESSH(N-1,X)-(DFLOAT(N)/X)*BESSH(N,X)
      ENDIF
      RETURN
      END


text:
        SUBROUTINE DMNMAX(A,N,AMIN,MINPOS,AMAX,MAXPOS)
*
*  Module number: FOS/HRS UTILITY
*
*  Module name: DMNMAX
*
*  Keyphrase:
*  ----------
*       find minimum and maximum
*  Description:
*  ------------
*       This routine finds the minimum and maximum and their
*       positions in an integer vector
*
*  FORTRAN name: DMNMAX.for
*
*  Keywords of accessed files and tables:
*  --------------------------------------
*  none
*
*  Subroutines Called:
*  -------------------
*       none
*
*  History:
*  --------
*  Version      Date        Author          Description
*    1          Oct. 87   D. Lindler    Designed and coded
*-------------------------------------------------------------------------------
C
C INPUT PARAMETERS
C
C       A - REAL*8 VECTOR
C       N - NUMBER OF POINTS IN A (INTEGER)
C
C OUTPUT PARAMETERS
C
C       AMIN - MINIMUM VALUE OF A (REAL*8)
C       MINPOS - POSITION OF MINIMUM (INTEGER)
C       AMAX - MAXIMUM VALUE OF A (REAL*8)
C       MAXPOS - POSITION OF MAXIMUM (INTEGER)
C
C----------------------------------------------------------------------------
	IMPLICIT NONE
        INTEGER N,MINPOS,MAXPOS
        DOUBLE PRECISION A(N),AMIN,AMAX
C
C LOCAL VARIABLES
C
        INTEGER I
C
C SET MIN AND MAX TO FIRST ELEMENT
C
        MINPOS=1
        MAXPOS=1
        AMIN=A(1)
        AMAX=A(1)
C
C LOOP ON ELEMENTS
C
        DO 10 I=1,N
                IF(A(I).LT.AMIN)THEN
                        AMIN=A(I)
                        MINPOS=I
                ENDIF
                IF(A(I).GT.AMAX)THEN
                        AMAX=A(I)
                        MAXPOS=I
                ENDIF
10      CONTINUE
        RETURN
        END

max_stars_repo_name: iraf-community/stsdas


text:
 SUBROUTINE inpd19 (task, iwrit, elsnam, nelms)
 !   READ control DATA for element number 19 (TL PST++)
 USE ele19_db
 USE ctrl_db, ONLY : ntype
 IMPLICIT NONE

   ! dummy arguments
   CHARACTER(len=*),INTENT(IN):: elsnam    ! element set name
   CHARACTER(len=*),INTENT(IN):: task      ! requested task
   INTEGER (kind=4) :: nelms,   & ! number of element sets
                       iwrit      ! flag to echo data input
   ! local variables
   LOGICAL :: oldset
   INTEGER (kind=4) :: nreqs, narch, nelem, i

   TYPE (ele19_set), POINTER, SAVE  :: elset, anter

   IF (TRIM(task) == 'INPUT') THEN
     ! check if list of sets and set exists and initializes
     CALL srch_ele19 (head, anter, elset, elsnam, oldset)
     IF (oldset) THEN    !if set exists
       CALL comm19 (1, nelem,  nreqs, narch, elsnam, elset)
       elset%lside = .FALSE.  !initializes flag to compute LSIDE
     ELSE                !set ELSNAM does not exist
       CALL new_ele19(elset)  !reserve memory for set
       CALL listen('INPD19')  !read a line
       elset%eulrf = exists('EULFRM') ! use a Eulerian Formulation
       IF (elset%eulrf .AND. ntype == 1) &
         CALL runen3('RESV19: EULER FORMULATION not allowed in plane stress')
       IF (exists('NOSWAP')) elset%swapc = .FALSE.  ! not swap alone elements in corners
       elset%angdf=getrea('ANGLE ',0d0,' Default angle between X1 and Ort_1')
       nreqs=getint('NREQS ',0,' Gauss pt for stress time history..')
       !?      IF( nreqs > 0 )NULLIFY( elset%ngrqs )
       narch  =  0           !to check
       nelem  =  0           !new set, initializes number of elements
       IF(iwrit == 1)WRITE(lures,"(/,5X,'CONTROL PARAMETERS FOR 2-D TRIANGLE ' &
                     &       //,5X,'REQUIRED STRESS (NREQS) =',I10,/)",ERR=9999) nreqs
     END IF

     !  read new data or add to previous data
     CALL elmd19(nelem, elset%head, elset%tail, iwrit, elset%eulrf)
     elset%plstr = 0       ! do not compute plastic strains
     ALLOCATE(elset%eside(3,nelem)) !reserve memory for neighbor elements
     elset%eside = 0     !initializes
     IF (.NOT.oldset) CALL rdreqs (ngaus, nreqs, elset%ngrqs, iwrit )

     CALL comm19(0, nelem,  nreqs, narch, elsnam, elset)
     ! add to the list of sets
     IF (.NOT.oldset) THEN
       CALL add_ele19 (elset, head, tail)
       nelms = nelms + 1 ! increased set counter for this element type
     END IF

   ELSE IF (TRIM(task) == 'RESTAR') THEN

     CALL new_ele19(elset)  !reserve memory for set
     ! read control parameters
     elset%sname = elsnam
     READ (51) elset%nelem, elset%nreqs, elset%narch, &
               elset%gauss, elset%lside, elset%eulrf, elset%plstr, elset%angdf
     ALLOCATE(elset%eside(3,elset%nelem))
     READ(51) (elset%eside(:,i),i=1,elset%nelem)
     nreqs = elset%nreqs
     IF (nreqs > 0)THEN
       ALLOCATE(elset%ngrqs(nreqs))
       READ(51) (elset%ngrqs(i), i=1,nreqs)
     END IF
     ! restore list of elements
     CALL rest19 (elset%nelem,  elset%head, elset%tail)
     ! add to list of elements
     CALL add_ele19 (elset, head, tail)

   ELSE
     CALL runend('INPD19: NON-EXISTENT TASK .        ')
   END IF

 RETURN
 9999 CALL runen2('')

 END SUBROUTINE inpd19

max_stars_repo_name: jerebenitez/IFE-simpact-openfoam

max_issues_repo_name: jerebenitez/IFE-simpact-openfoam

max_forks_repo_name: jerebenitez/IFE-simpact-openfoam


text:
 SUBROUTINE elemt8(TASK, nelms, elsnam, dtime, ttime, istop, &
                   ivect, flag1, flag2)

 USE ctrl_db, ONLY: ndime, ndofn, npoin, lumped
 USE outp_db, ONLY: iwrit
 USE outp_db, ONLY: sumat
 USE ele08_db
 USE npo_db

 IMPLICIT NONE

 CHARACTER(len=*),INTENT(IN):: TASK

 ! optional parameters

 LOGICAL, OPTIONAL :: flag1,flag2
 CHARACTER (len=*), OPTIONAL :: elsnam
 INTEGER (kind=4), OPTIONAL :: istop,  ivect(:), nelms(:)
 REAL (kind=8), OPTIONAL :: dtime,ttime

 CHARACTER(len=mnam) :: sname

 INTEGER (kind=4) nelem,nnode,ngaus,axesc,narch,nreqs

 TYPE (ele08_set), POINTER :: elset, anter

 IF ( .NOT.ASSOCIATED (head) ) RETURN

 NULLIFY (anter)
 elset => head

 DO

   CALL commv8 (1,     nelem, nnode, ngaus, axesc,               &
                nreqs, narch, sname, elset)

   SELECT CASE (TRIM(task))

   CASE ('GAUSSC')
   CALL gauss8(ndime,nelem,nnode,ngaus,elset%axesc,elset%head,coord,   &
               eule0,elset%posgp,elset%shape,elset%deriv,        &
               elset%weigh,flag1,istop)

   !CASE ('LOADPL')
   !CALL loadp8(ndime,ndofn,nelem,loadv(:,:,iload),               &
   !            gvect,gravy,nnode,ngaus,axesc,elset%head,         &
   !            elset%shape,elset%weigh)

   CASE ('CLOSEF')
   CALL close1(nreqs,narch)

   CASE ('LUMASS')
   !CALL lumas8(ndime,nelem,iwrit,nnode,ngaus,axesc,              &
   !            elset%head,elset%weigh,emass,elset%shape,sumat)
   CALL masmt8(ndime,nelem,iwrit,nnode,ngaus,axesc,              &
               elset%head,elset%weigh,emass,elset%shape,sumat,ymass,lumped)

   CASE ('NEW','NSTRA1','NSTRA2')
   CALL acvdf8(nelem,nnode,ifpre,elset%head)

   CASE ('UPDLON')
   CALL updlo8(nelem,nnode,elset%head,oldlb)

   CASE ('OUTDYN')
   IF(flag1.OR.flag2)                                            &
     CALL outdy8(flag1,flag2,nelem,nreqs,narch,iwrit,ngaus,      &
                 elset%ngrqs,ttime,elset%head)

   CASE ('RESVPL')
   CALL resvp8(ndime,nelem,nnode,ngaus,axesc,coora,              &
               euler,velnp,resid,elset%weigh,elset%shape,        &
               elset%deriv,elset%head,istop)

   CASE ('DUMPIN')
     CALL dumpi8 (sname, nelem, nnode, ngaus, axesc, nreqs,         &
                  narch, elset%head, elset%ngrqs,                   &
                  elset%posgp, elset%shape, elset%deriv, elset%weigh)

   CASE ('WRTPOS')
   CALL masel8(nnode,ngaus,nreqs,nelem,narch,elset%head,              &
               elset%ngrqs,elset%sname)
    elset%narch = narch

   CASE ('INCDLT')
   CALL deltc8(nelem,ndime,nnode,dtime,elset%head,coora)

   CASE ('DELETE')
     flag2 = TRIM(elsnam) == TRIM(sname)
     IF (flag2) THEN
       CALL del_ele08 (head, tail, anter, elset)
       nelms(8) = nelms(8) - 1
       EXIT
     END IF
     IF ( ASSOCIATED (elset%next) ) anter => elset

   CASE ('SURFAC')      !compute contact surface
     IF( flag2 )EXIT
     flag2 = TRIM(elsnam) == TRIM(sname)
     IF (flag2) THEN
       ! get surface definition from the element set
       CALL surf08 (elset%head,elset%nelem)
       EXIT
     END IF

   END SELECT

   IF ( ASSOCIATED (elset%next) ) THEN
     elset => elset%next
   ELSE
     EXIT
   END IF

 END DO

 RETURN

 END SUBROUTINE elemt8


text:
************************************************************************
* This file collects the initialization routines for NSDEF.
*
* The routines here build the general parameter structures for the
* call to NSDEF2 solver.
************************************************************************

************************************************************************
* Initialize NSDEF stationary solver structures
*
* This initializes the IPARAM/DPARAM structure arrays, which are
* used in the call of NSDEF, with standard values. If desired,
* values of the COMMON-blocks are transferred to these structure
* arrays.
*
* The routine does not allocate any memory, it just initializes the
* parameters.
*
* In:
*   IPARAM : array [1..SZNSDI] of integer
*            Integer parameter block for NSDEF
*   DPARAM : array [1..SZNSDD] of double
*            Double precision parameter block for NSDEF
*   IC2PAR : =0: initialize IPARAM/DPARAM only with standard values
*            =1: initialize IPARAM/DPARAM with standard values and
*                transfer values of COMMON-blocks into them
*
* Out:
*   IPARAM,
*   DPARAM : Initialized structures
*
* This routine does not allocate any memory and does not initialize
* the DString-handles of the basic filenames for file output. This
* has to be done by the caller if necessary!
************************************************************************

      SUBROUTINE INISTS(IPARAM,DPARAM,IC2PAR)

      IMPLICIT NONE

      INCLUDE 'cout.inc'

      INCLUDE 'cbasicmg.inc'
      INCLUDE 'stria.inc'
      INCLUDE 'ssolvers.inc'
      INCLUDE 'slinsol.inc'
      INCLUDE 'slinsol2dns.inc'
      INCLUDE 'smat2dns.inc'
      INCLUDE 'stiming.inc'
      INCLUDE 'snsdef.inc'

      INCLUDE 'cnonlinsol_cc2d.inc'
      INCLUDE 'cpostproc.inc'

      INTEGER IPARAM(SZNSDI),IC2PAR
      DOUBLE PRECISION DPARAM(SZNSDD)

C     Clean the arrays

      CALL LCL1 (DPARAM,SZNSDD)
      CALL LCL3 (IPARAM,SZNSDI)

C     Set up standard values.
C     At first call the standard initialization routine for the standard
C     solver structure.

      CALL INGSLV (IPARAM, DPARAM)

C     Some standard values are not used by NSDEF, set them to 0.
C     Others have different <> 0 standard values - initialize them.

      IPARAM (ONITMAX) = 20
      IPARAM (OTIM  )  = 2
      IPARAM (OIASRLN) = 0
      IPARAM (OMSGTRM) = 2
      IPARAM (OMTRMRS) = 1

      DPARAM (OEPSREL) = 0D0
      DPARAM (OEPSABS) = 0D0
      DPARAM (ODIVREL) = 0D0
      DPARAM (ODIVABS) = 0D0
      DPARAM (OVECZER) = 0D0

C     Initialize extended parameters which are different from 0.

      IPARAM (OSLTAG)  = 20
      IPARAM (OMSGLIN) = 1

C     Should we transfer COMMON-block variables?

      IF (IC2PAR.NE.0) THEN

        IPARAM (ONITMIN) = INLMIN
        IPARAM (ONITMAX) = INLMAX
        IPARAM (OMSGTRM) = MT

        IPARAM (OIAUSAV) = IAUSAV

        DPARAM (OOMGINI) = OMGINI
        DPARAM (OOMGMIN) = OMGMIN
        DPARAM (OOMGMAX) = OMGMAX

C       Transfer stopping criteria

        DPARAM (OEPSD  ) = EPSD
        DPARAM (OEPSDIV) = EPSDIV
        DPARAM (OEPSUR ) = EPSUR
        DPARAM (OEPSPR ) = EPSPR
        DPARAM (ODMPD  ) = DMPD

      END IF

      END

************************************************************************
* Initialize structure for linear solver in NSDEF stationary solver
*
* This initializes the IPARAM/DPARAM structure arrays, which define the
* behaviour of the linear solver that is used as sub-solver in
* NSDEF2. If desired, values of the COMMON-blocks are transferred to
* these structure arrays.
*
* The routine does not allocate any memory, it just initializes the
* parameters.
*
* IPARAM/DPARAM should be filled with 0 before calling this routine,
* as here only the nonzero parameters are set.
*
* In:
*   NLMIN  : Minimum level in multigrid; >= 1
*   NLMAX  : Maximum level in multigrid; <= 9
*   IPARAM : array [1.SZ020I+3*SZSLVI] of integer
*            Integer parameter block of solver structure for NSDEF2.
*   DPARAM : array [1..SZ020D+3*SZSLVD] of double
*            Double precision parameter block of structure
*            of linear solver
*   ISLV   : Type of solver that should be used.
*            =0: Multigrid solver
*            =1: UMFPACK (1-level) solver
*   IC2PAR : =0: initialize IPARAM/DPARAM only with standard values
*            =1: initialize IPARAM/DPARAM with standard values and
*                transfer values of COMMON-blocks into them
*
* Out:
*   IPARAM,
*   DPARAM : Initialized structures for solver, multigrid, smoother and
*            coarse grid solver
*
* After calling this routine, the first solver structure in IPARAM
* decides on which solver is used. The caller should call the
* correct solver depending on the solver tag in this structure.
************************************************************************

      SUBROUTINE INLSST (NLMIN,NLMAX,IPARAM,DPARAM,ISLV,IC2PAR)

      IMPLICIT NONE

      INCLUDE 'cout.inc'
      INCLUDE 'cbasicmg.inc'
      INCLUDE 'ssolvers.inc'
      INCLUDE 'm020.inc'

      INCLUDE 'clinsol_cc2d.inc'

C     parameters

      INTEGER IPARAM(*),IC2PAR,NLMIN,NLMAX,ISLV
      DOUBLE PRECISION DPARAM(*)

C     Should we use a standard MG solver?

      IF (ISLV.EQ.0) THEN

C       Ok. Call INMGST to initialize the standard MG solver
C       structure. IPARAM contains two or three substructures:
C       - Multigrid solver with VANCA smoother
C       - (Vanca Coarse) grid solver
C       or (in future versions)
C       - Multigrid solver with VANCA smoother
C       - Smoother-structure for advanced
C       - (Vanca Coarse) grid solver

        CALL INMGST (NLMIN,NLMAX,IPARAM,DPARAM,IC2PAR)

      ELSE IF (ISLV.EQ.1) THEN

C       The user wants to use BiCGStab-solver with a
C       multigrid preconditioner.
C       IPARAM contains three or four substructures:
C       - BiCGStab-solver
C       - Multigrid preconditioner with VANCA smoother
C       - (Vanca Coarse) grid solver
C       or (in future versions)
C       - BiCGStab-solver
C       - Multigrid preconditioner
C       - Smoother-structure for advanced
C       - (Vanca Coarse) grid solver
C
C       Initialize the BiCGStab-structure with standard
C       solver parameters:

        CALL INGSLV (IPARAM, DPARAM)

C       Initialize the tag to indicate a BiCGStab-solver:

        IPARAM(OSLTAG) = 6

C       Call INMGST to initialize the standard MG solver
C       structure, which is later modified to be a
C       preconditioning structure. The structure is found
C       at the second block of IPARAM/DPARAM behind the
C       BiCGStab solver structure.

        CALL INMGST (NLMIN,NLMAX,
     *               IPARAM(SZSLVI+1),DPARAM(SZSLVD+1),IC2PAR)

C       Modify the solver structure to form the structure of a
C       multigrid preconditioner.
C       Initialize the tag to indicate a Multigrid preconditioner.
C       Inform the BiCGStab solver that we have a preconditioner.

        IPARAM(SZSLVI+OSLTAG) = 111
        IPARAM(OPCTAG)        =  11

C       Initialize minimum and maximum iterations of the
C       preconditioner:

        IPARAM(SZSLVI+ONITMIN) = 2
        IPARAM(SZSLVI+ONITMAX) = 2

C       Reduce the message level of the MG components by 2

        IPARAM(SZSLVI+OMSGTRM) = IPARAM(SZSLVI+OMSGTRM)-2
        IPARAM(SZSLVI+OMCGTRM) = IPARAM(SZSLVI+OMCGTRM)-2
        IPARAM(SZSLVI+OMSMTRM) = IPARAM(SZSLVI+OMSMTRM)-2

C       Set the message level for BiCGStab differently to the
C       standard initialization.

        IPARAM(OMSGTRM) = MT-2

C       Transfer COMMON block variables from DAT file

        IF (IC2PAR.NE.0) THEN

C         Number of preconditioning steps is written to min.+max.
C         number of iterations of the MG component.
C         This deactivates any stopping criterion.

          IPARAM (SZSLVI+ONITMIN) = IPCMG
          IPARAM (SZSLVI+ONITMAX) = IPCMG

C         Min./Max. number of iterations of BiCGStab

          IPARAM (ONITMIN) = ILMIN
          IPARAM (ONITMAX) = ILMAX

C         Stopping criteria for BiCGStab.

          DPARAM (OEPSREL) = EPSMG
          DPARAM (OEPSABS) = DMPMG
        END IF

      ELSE IF (ISLV.EQ.2) THEN

C       The user wants to use a standard UMFPACK4 direct solver.
C       We can easily prepare the structure in IPARAM, which
C       contains only one block, configured as standard solver
C       structure:

        CALL INGSLV (IPARAM, DPARAM)

C       Note the type of solver in IPARAM

        IPARAM(OSLTAG) = 13

C       Nothing more to do.

      END IF

      END

************************************************************************
* Initialize Multigrid structure for NSDEF-solver
*
* This initializes the IPARAM/DPARAM structure arrays, which define the
* behaviour of the multigrid solver that is used as sub-solver in
* NSDEF2. If desired, values of the COMMON-blocks are transferred to
* these structure arrays.
*
* The routine does not allocate any memory, it just initializes the
* parameters.
*
* IPARAM/DPARAM should be filled with 0 before calling this routine,
* as here only the nonzero parameters are set.
*
* In:
*   NLMIN  : Minimum level in multigrid; >= 1
*   NLMAX  : Maximum level in multigrid; <= 9
*   IPARAM : array [1.SZ020I+3*SZSLVI] of integer
*            Integer parameter block of MG structure for NSDEF2
*   DPARAM : array [1..SZ020D+3*SZSLVD] of double
*            Double precision parameter block of MG structure
*            for NSDEF2
*   IC2PAR : =0: initialize IPARAM/DPARAM only with standard values
*            =1: initialize IPARAM/DPARAM with standard values and
*                transfer values of COMMON-blocks into them
*
* Out:
*   IPARAM,
*   DPARAM : Initialized structures for multigrid, smoother and
*            coarse grid solver
************************************************************************

      SUBROUTINE INMGST (NLMIN,NLMAX,IPARAM,DPARAM,IC2PAR)

      IMPLICIT NONE

      INCLUDE 'cout.inc'
      INCLUDE 'cbasicmg.inc'
      INCLUDE 'ssolvers.inc'
      INCLUDE 'm020.inc'

      INCLUDE 'clinsol_cc2d.inc'

C     parameters

      INTEGER IPARAM(*),IC2PAR,NLMIN,NLMAX
      DOUBLE PRECISION DPARAM(*)

C     local variables

      INTEGER IDX

C     The xPARAM structure arrays contain information for three
C     different type of iterative algorithms: (Multigrid) solver,
C     smoother and coarse grid solver.
C
C     The standard configuration is:
C       - Multigrid solver
C       - Vanca Smoother
C       - Vanca Coarse grid solver
C     So we initialize the structures according to that.
C
C     The first part contains information that configures the
C     solver itself. Initialize it with the standard MG initialization
C     routine:

      CALL INM020 (IPARAM, DPARAM)

C     The second part configures the smoother. Initialize that with
C     standard values:

      CALL INGSLV (IPARAM(1+SZ020I), DPARAM(1+SZ020D))

C     The third part configures the coarse grid solver, which is in
C     the standard case a VANCA pseudo-solver. Nevertheless, it's an
C     iterative  solver that requires an appropriate solver structure.

      CALL INGSLV (IPARAM(1+SZ020I+SZSLVI), DPARAM(1+SZ020D+SZSLVD))

      IF (IC2PAR.NE.0) THEN

C       The user wants us to transfer COMMON block variables to
C       the solver structure for initialization. This allowes to
C       configure/initialize the solver more precisely.

C       Message level is two below the current message level

        IPARAM(OMSGTRM) = MT-2

C       Set the output level of the coarse grid solver to the
C       general output level - 4

        IPARAM(OMCGTRM) = MT-4

C       Set the output level of the smoother to the
C       general output level - 6

        IPARAM(OMSMTRM) = MT-6

C       Preset of minimum/maximum level. Might be changed in NSDEF.

        IPARAM(ONITMIN) = ILMIN
        IPARAM(ONITMAX) = ILMAX

C       Stopping criteria for MG solver:

        DPARAM(OEPSABS) = EPSMG
        DPARAM(OEPSREL) = DMPMG

C       Minimum/maximum value for the optimal correction:

        DPARAM(OSTPMIN) = AMINMG
        DPARAM(OSTPMAX) = AMAXMG

C       Configure the smoother. We only support basic smoothing,
C       so we don't have to pass much information to the callback
C       routines. At first, initialize the smoother tag to identify
C       out VANCA. That's not used by the MG algorithm internally,
C       but it's good style to do this...
C
C       VANCA = 50+ISM

        IPARAM(OSMTAG) = 50+ISM

C       Initialize the relaxation parameter of the smoother

        DPARAM(OOMGSM) = RLXSM

C       Build up the number of smoothing steps using the parameters
C       from the COMMON blocks.

        DO IDX = NLMIN,NLMAX
          IPARAM (OKPRSM+IDX-1) = NSM * NSMFAC**(NLMAX-IDX)
          IPARAM (OKPOSM+IDX-1) = NSM * NSMFAC**(NLMAX-IDX)
        END DO

C       That's it for the smoother. Now configure the grid transfer.
C       We configure PRRSI/PRRSD as follows to pass parameters to the
C       callback routines for prolongation/restriction:
C
C         PRRSI(1) = IINT
C         PRRSI(2) = IAPRM
C         PRRSI(3) = IAVPR
C
C         PRRSD(1) = DPREP

        IPARAM(OPRRSI)   = IINT
        IPARAM(OPRRSI+1) = IAPR
        IPARAM(OPRRSI+2) = IAVPR

        DPARAM(OPRRSD)   = DPREP

C       Now we come to the initialization of the coarse grid solver.
C
C       Remember that all variables initialized here for the smoother/
C       coarse grid solver are only pseudotypically prescribed!
C       They are initialized in a rather structured way, but only serve
C       to pass information to the corresponding callback-routines of NSDEF!
C       All information written in the structures here is only used
C       by the callback-routines of NSDEF - nowhere else!
C       That way we have a template so that we can theoretically switch
C       to another smoother/solver later, as the structure is the same
C       for all kinds of smoothers/solvers.

C       Configure the coarse grid solver:

        IDX = SZ020I

C       Maximum number of iterations:

        IPARAM(IDX+ONITMAX) = NSL

C       Which type of coarse grid solver do we actually have?
C       ISL decides about that.

        IF (ISL.EQ.10) THEN

C         ISL=10 -> Type of solver: 13=UMFPACK4

          IPARAM(IDX+OSLTAG) = 13

        ELSE

C         ISL=0 -> Type of solver: 50=VANCA
C         ISL=1 -> Type of solver: 51=Extended VANCA
C         ISL=2 -> Type of solver: 50=VANCA, defect correction
C         ISL=3 -> Type of solver: 51=Extended VANCA, defect correction

          IPARAM(IDX+OSLTAG) = 50+ISL

        END IF

C       Absolute and relative error bound

        IDX = SZ020D

        DPARAM(IDX+OEPSABS) = EPSSL
        DPARAM(IDX+OEPSREL) = DMPSL

C       Standard relative divergence criterion

        DPARAM(IDX+ODIVREL) = 1D6

C       Save the OMEGA relaxation parameter for coarse grid solver

        DPARAM(IDX+OOMEGA)  = RLXSL

      END IF

C     Activate the following setting to get coarse grid solver output:
C
C      IPARAM(OMCGTRM) = 2

      END


text:
C$Procedure ZZBODBLT ( Private --- Retrieve Built-In Body-Code Maps )

      SUBROUTINE ZZBODBLT ( ROOM,  NAMES,  NORNAM, CODES,
     .                      NVALS, DEVICE, REQST          )

C$ Abstract
C
C     SPICE Private routine intended solely for the support of SPICE
C     routines.  Users should not call this routine directly due
C     to the volatile nature of this routine.
C
C     This is the umbrella routine that contains entry points to
C     access the built-in body name-code mappings.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     BODY
C
C$ Declarations

      IMPLICIT NONE

      INCLUDE              'zzbodtrn.inc'

      INTEGER               ROOM
      CHARACTER*(*)         NAMES  ( * )
      CHARACTER*(*)         NORNAM ( * )
      INTEGER               CODES  ( * )
      INTEGER               NVALS
      CHARACTER*(*)         DEVICE
      CHARACTER*(*)         REQST

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     ROOM       I   ZZBODGET
C     NAMES      O   ZZBODGET
C     NORNAM     O   ZZBODGET
C     CODES      O   ZZBODGET
C     NVALS      O   ZZBODGET
C     DEVICE     I   ZZBODLST
C     REQST      I   ZZBODLST
C
C$ Detailed_Input
C
C     See the entry points for a discussion of their arguments.
C
C$ Detailed_Output
C
C     See the entry points for a discussion of their arguments.
C
C$ Parameters
C
C     See the include file 'zzbodtrn.inc' for the list of parameters
C     this routine utilizes.
C
C$ Exceptions
C
C     1) The error SPICE(BOGUSENTRY) is signaled if ZZBODBLT is
C        called directly.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     ZZBODBLT should never be called directly, instead access
C     the entry points:
C
C        ZZBODGET      Fetch the built-in body name/code list.
C
C        ZZBODLST      Output the name-ID mapping list.
C
C$ Examples
C
C     See ZZBODTRN and its entry points for details.
C
C$ Restrictions
C
C     1) No duplicate entries should appear in the built-in
C        BLTNAM list.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     F.S. Turner     (JPL)
C     B.V. Semenov    (JPL)
C
C$ Version
C
C-    SPICELIB Version 2.3.1, 27-FEB-2007 (EDW)
C
C        Completed the ZZBODLST decalrations section.
C
C-    SPICELIB Version 2.3.0, 17-MAR-2003 (EDW)
C
C        Added a call to ZZIDMAP to retrieve the default
C        mapping list. "zzbodtrn.inc" no longer
C        contains the default mapping list.
C
C-    SPICELIB Version 2.2.0  21-FEB-2003 (BVS)
C
C        Changed MER-A and MER-B to MER-1 and MER-2.
C
C-    SPICELIB Version 2.1.0  04-DEC-2002 (EDW)
C
C       Added new assignments to the default collection:
C
C       -226     ROSETTA
C        517     CALLIRRHOE
C        518     THEMISTO
C        519     MAGACLITE
C        520     TAYGETE
C        521     CHALDENE
C        522     HARPALYKE
C        523     KALYKE
C        524     IOCASTE
C        525     ERINOME
C        526     ISONOE
C        527     PRAXIDIKE
C
C-    SPICELIB Version 2.0.0, 23-AUG-2002 (FST)
C
C        Initial release.  This begins at Version 2.0.0 because
C        the entry point ZZBODLST was cut out of ZZBODTRN and
C        placed here at Version 1.0.0.
C-&

C$ Revisions
C
C-    SPICELIB Version 2.0.0, 23-AUG-2002 (FST)
C
C        The entries following this one were copied from
C        the version section of ZZBODTRN.  SPICELIB has
C        been changed to ZZBODTRN for convenience in noting
C        version information relevant for that module.
C
C        This was done to carry the history of body name-code
C        additions with this new umbrella.
C
C        Added to the collection:
C        -236   MESSENGER
C
C-    ZZBODTRN Version 3.2.0, 14-AUG-2002 (EDW)
C
C        Added the ZZBODKIK entry point.
C
C        Moved the NAIF_BODY_NAME/CODE to subroutine
C        ZZBODKER. No change in logic.
C
C        Added logic to enforce the precedence masking;
C        logic removes duplicate assignments of ZZBODDEF.
C        Removed the NAMENOTUNIQUE error block.
C
C-    ZZBODTRN Version 3.1.5, 27-NOV-2001 (EDW)
C
C        Added to the collection:
C        -200   CONTOUR
C        -146   LUNAR-A
C        -135   DRTS-W
C
C        Added the subroutine ZZBODLST as an entry point.
C        The routine outputs the current name-ID mapping
C        list to some output device.
C
C-    ZZBODTRN Version 3.1.0, 17-OCT-2001 (EDW)
C
C        To improve clarity, the BEGXX block initialization now
C        exists in the include file zzbodtrn.inc.
C
C        Removed the comments concerning the 851, 852, ... temporary
C        codes.
C
C        Set the WNAMES assignment to NAIF_BODY_CODE, NAIF_BODY_NAME
C        as a DATA statement.
C
C        Edited headers to match information in naif_ids required
C        reading.
C
C        Edited headers, removed typos and bad grammar, clarified
C        descriptions.
C
C        Added to the collection
C        -41    MARS EXPRESS, MEX
C        -44    BEAGLE 2, BEAGLE2
C        -70    DEEP IMPACT IMPACTOR SPACECRAFT
C        -94    MO, MARS OBSERVER
C        -140   DEEP IMPACT FLYBY SPACECRAFT
C        -172   SLCOMB, STARLIGHT COMBINER
C        -205   SLCOLL, STARLIGHT COLLECTOR
C        -253   MER-A
C        -254   MER-B
C
C        Corrected typo, vehicle -188 should properly be MUSES-C,
C        previous versions listed the name as MUSES-B.
C
C        Removed from collection
C        -84    MARS SURVEYOR 01 LANDER
C        -154   EOS-PM1
C        -200   PLUTO EXPRESS 1, PEX1
C        -202   PLUTO EXPRESS 2, PEX2
C
C-    ZZBODTRN Version 3.0.0, 29-MAR-2000 (WLT)
C
C        The ID codes for Cluster 1, 2, 3 and 4 were added.  The
C        ID coded for Pluto Express were removed.  The ID codes
C        for Pluto-Kuiper Express, Pluto-Kuiper Express Simulation
C        and Contour were added.
C
C-    ZZBODTRN Version 2.0.0, 26-JAN-1998 (EDW)
C
C        The Galileo probe ID -228 replaces the incorrect ID -344.
C        DSS stations 5 through 65 added to the collection.
C
C        Added to the collection
C        -107   TROPICAL RAINFALL MEASURING MISSION, TRMM
C        -154,  EOS-PM1
C        -142   EOS-AM1
C        -151   AXAF
C        -1     GEOTAIL
C        -13    POLAR
C        -21    SOHO
C        -8     WIND
C        -25    LUNAR PROSPECTOR, LPM
C        -116   MARS POLAR LANDER, MPL
C        -127   MARS CLIMATE ORBITER, MCO
C        -188   MUSES-C
C        -97    TOPEX/POSEIDON
C        -6     PIONEER-6, P6
C        -7     PIONEER-7, P7
C        -20    PIONEER-8, P8
C        -23    PIONEER-10, P10
C        -24    PIONEER-11, P11
C        -178   NOZOMI, PLANET-B
C        -79    SPACE INFRARED TELESCOPE FACILITY, SIRTF
C        -29    STARDUST, SDU
C        -47    GENESIS
C        -48    HUBBLE SPACE TELESCOPE, HST
C        -200   PLUTO EXPRESS 1, PEX1
C        -202   PLUTO EXPRESS 2, PEX2
C        -164   YOHKOH, SOLAR-A
C        -165   MAP
C        -166   IMAGE
C        -53    MARS SURVEYOR 01 ORBITER
C         618   PAN
C         716   CALIBAN
C         717   SYCORAX
C        -30    DS-1 (low priority)
C        -58    HALCA
C        -150   HUYGEN PROBE, CASP
C        -55    ULS
C
C        Modified ZZBODC2N and ZZBODN2C so the user may load an
C        external IDs kernel to override or supplement the standard
C        collection.  The kernel must be loaded prior a call to
C        ZZBODC2N or ZZBODN2C.
C
C-    ZZBODTRN Version 1.1.0, 22-MAY-1996 (WLT)
C
C        Added the id-code for Comet Hyakutake, Comet Hale-Bopp,
C        Mars 96, Cassini Simulation, MGS Simulation.
C
C-    ZZBODTRN Version 1.0.0, 25-SEP-1995 (BVS)
C
C        Renamed umbrella subroutine and entry points to
C        correspond private routine convention (ZZ...). Added IDs for
C        tracking stations Goldstone (399001), Canberra (399002),
C        Madrid (399003), Usuda (399004).
C
C-    ZZBODTRN Version 2.2.0, 01-AUG-1995 (HAN)
C
C        Added the IDs for Near Earth Asteroid Rendezvous (-93),
C        Mars Pathfinder (-53), Ulysses (-55), VSOP (-58),
C        Radioastron (-59), Cassini spacecraft (-82), and Cassini
C        Huygens probe (-150).
C        Mars Observer (-94) was replaced with Mars Global
C        Surveyor (-94).
C
C-    ZZBODTRN Version 2.1.0, 15-MAR-1995 (KSZ) (HAN)
C
C        Two Shoemaker Levy 9 fragments were added, Q1 and P2
C        (IDs 50000022 and 50000023). Two asteroids were added,
C        Eros and Mathilde (IDs 2000433 and 2000253). The
C        Saturnian satellite Pan (ID 618) was added.
C
C-    ZZBODTRN Version 2.0.0, 03-FEB-1995 (NJB)
C
C        The Galileo probe (ID -344) has been added to the permanent
C        collection.
C
C-    ZZBODTRN Version 1.0.0, 29-APR-1994 (MJS)
C
C        SPICELIB symbol tables are no longer used. Instead, two order
C        vectors are used to index the NAMES and CODES arrays. Also,
C        this version does not support reading body name ID pairs from a
C        file.
C
C-    ZZBODTRN Version 2.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    ZZBODTRN Version 2.0.0, 15-JUL-1991 (WLT)
C
C       The body id's for the Uranian satellites discovered by Voyager
C       were modified to conform to those established by the IAU
C       nomenclature committee.  In addition the id's for Gaspra and
C       Ida were added.
C
C-    ZZBODTRN Version 1.0.0,  7-MAR-1991 (WLT)
C
C       Some items previously considered errors were removed
C       and some minor modifications were made to improve the
C       robustness of the routines.
C
C-    ZZBODTRN Version 1.0.0, 28-JUN-1990 (JEM)
C
C-&

C
C     SPICELIB Functions
C
      INTEGER               LASTNB

      LOGICAL               EQSTR
      LOGICAL               RETURN

C
C     Local Parameters
C

C
C     Local Variables
C
      CHARACTER*(MAXL)      BLTNAM ( NPERM )
      CHARACTER*(MAXL)      BLTNOR ( NPERM )
      CHARACTER*(4)         ZZRQST
      CHARACTER*(MAXL)      ZZINT
      CHARACTER*(2*MAXL+3)  ZZLINE

      INTEGER               BLTCOD ( NPERM )
      INTEGER               I
      INTEGER               ZZOCOD ( NPERM )
      INTEGER               ZZONAM ( NPERM )

      LOGICAL               FIRST

C
C     Saved Variables
C
      SAVE                  BLTCOD
      SAVE                  BLTNAM
      SAVE                  BLTNOR
      SAVE                  FIRST

C
C     Data Statements
C
      DATA                  FIRST     / .TRUE. /

C
C     Standard SPICE error handling.
C
      IF ( RETURN() ) THEN
         RETURN
      ELSE
         CALL CHKIN  ( 'ZZBODBLT'          )
         CALL SIGERR ( 'SPICE(BOGUSENTRY)' )
         CALL CHKOUT ( 'ZZBODBLT'          )
      END IF

      RETURN

C$Procedure ZZBODGET ( Private --- Body-Code Get Built-In List )

      ENTRY ZZBODGET ( ROOM, NAMES, NORNAM, CODES, NVALS )

C$ Abstract
C
C     SPICE Private routine intended solely for the support of SPICE
C     routines.  Users should not call this routine directly due
C     to the volatile nature of this routine.
C
C     Retrieve a copy of the built-in body name-code mapping lists.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     PRIVATE
C     BODY
C
C$ Declarations
C
C     INTEGER               ROOM
C     CHARACTER*(*)         NAMES  ( * )
C     CHARACTER*(*)         NORNAM ( * )
C     INTEGER               CODES  ( * )
C     INTEGER               NVALS
C
C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     ROOM       I   Space available in NAMES, NORNAM, and CODES.
C     NAMES      O   Array of built-in body names.
C     NORNAM     O   Array of normalized built-in body names.
C     CODES      O   Array of built-in ID codes for NAMES/NORNAM.
C     NVALS      O   Length of NAMES, NORNAM, CODES, and ORDNOM arrays.
C
C$ Detailed_Input
C
C     ROOM       is the maximum number of entries that NAMES, NORNAM,
C                and CODES may receive.
C
C$ Detailed_Output
C
C     NAMES      the array of built-in names.  This array is parallel
C                to NORNAM and CODES.
C
C     NORNAM     the array of normalized built-in body names.  This
C                array is computed from the NAMES array by compressing
C                groups of spaces into a single space, left-justifying
C                the name, and uppercasing the letters.
C
C     CODES      the array of built-in codes associated with NAMES
C                and NORNAM entries.
C
C     NVALS      the number of items returned in NAMES, NORNAM,
C                and CODES.
C
C$ Parameters
C
C     NPERM      the number of permanent, or built-in, body name-code
C                mappings.
C
C$ Exceptions
C
C     1) SPICE(BUG) is signaled if ROOM is less than NPERM, the
C        amount of space required to store the entire list of
C        body names and codes.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This routine simply copies it's local buffered version of the
C     built-in name-code mappings to the output arguments.
C
C$ Examples
C
C     See ZZBODTRN for sample usage.
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     F.S. Turner     (JPL)
C
C$ Version
C
C-    SPICELIB Version 2.1.0, 17-MAR-2003 (EDW)
C
C        Added a call to ZZIDMAP to retrieve the default
C        mapping list. "zzbodtrn.inc" no longer
C        contains the default mapping list.
C
C-    SPICELIB Version 2.0.0, 23-AUG-2002 (FST)
C
C-&

C
C     Standard SPICE error handling.
C
      IF ( RETURN() ) THEN
         RETURN
      ELSE
         CALL CHKIN ( 'ZZBODGET' )
      END IF

C
C     On the first invocation compute the normalized forms of BLTNAM
C     and store them in BLTNOR.
C
      IF ( FIRST ) THEN

C
C        Retrieve the default mapping list.
C
         CALL ZZIDMAP( BLTCOD, BLTNAM )

         DO I = 1, NPERM
            CALL LJUST  (         BLTNAM(I), BLTNOR(I) )
            CALL UCASE  (         BLTNOR(I), BLTNOR(I) )
            CALL CMPRSS ( ' ', 1, BLTNOR(I), BLTNOR(I) )
         END DO

C
C        Do not do this again.
C
         FIRST = .FALSE.

      END IF

C
C     Copy the contents of BLTNAM, BLTNOR, and BLTCOD to the output
C     arguments, but only if there is sufficient room.
C
      IF ( ROOM .LT. NPERM ) THEN

         CALL SETMSG ( 'Insufficient room to copy the stored '
     .   //            'body name-code mappings to the output '
     .   //            'arguments.  Space required is #, but '
     .   //            'the caller supplied #.'                 )
         CALL ERRINT ( '#', NPERM                               )
         CALL ERRINT ( '#', ROOM                                )
         CALL SIGERR ( 'SPICE(BUG)'                             )
         CALL CHKOUT ( 'ZZBODGET'                               )
         RETURN

      END IF

      CALL MOVEC ( BLTNAM, NPERM, NAMES  )
      CALL MOVEC ( BLTNOR, NPERM, NORNAM )
      CALL MOVEI ( BLTCOD, NPERM, CODES  )

      NVALS = NPERM

      CALL CHKOUT ( 'ZZBODGET' )
      RETURN

C$Procedure ZZBODLST ( Output permanent collection to some device. )

      ENTRY ZZBODLST ( DEVICE, REQST )

C$ Abstract
C
C     Output the complete list of built-in body/ID mappings to
C     some output devide. Thw routine generates 2 lists: one
C     sorted by ID number, one sorted by name.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     NONE.
C
C$ Keywords
C
C     BODY
C
C$ Declarations
C
C      CHARACTER*(*)         DEVICE
C      CHARACTER*(*)         REQST
C
C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     DEVICE     I   Device name to receive the output.
C     REQST      I   Data list name to output.
C
C$ Detailed_Input
C
C     DEVICE         identifies the device to receive the
C                    body/ID mapping list. WRLINE performs the
C                    output function and so DEVICE may have
C                    the values 'SCREEN' (to generate a screen dump),
C                    'NULL' (do nothing), or a device name (a
C                    file, or any other name valid in a FORTRAN OPEN
C                    statement).
C
C     REQST          A case insensitive string indicating the data
C                    set to output. REQST may have the value 'ID',
C                    'NAME', or 'BOTH'. 'ID' outputs the name/ID mapping
C                    ordered by ID number from least to highest value.
C                    'NAME' outputs the name/ID mapping ordered by ASCII
C                    sort on the name string. 'BOTH' outputs both
C                    ordered lists.
C
C$ Detailed_Output
C
C     None.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     None.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     The entry point outputs ordered lists of the name/ID mappings
C     defined in ZZBODTRN.
C
C$ Examples
C
C     1. Write both sorted lists to screen.
C
C     PROGRAM X
C
C     CALL ZZBODLST( 'SCREEN', 'BOTH' )
C
C     END
C
C     2. Write an ID number sorted list to a file, "body.txt".
C
C     PROGRAM X
C
C     CALL ZZBODLST( 'body.txt', 'ID' )
C
C     END
C
C With SCREEN output of the form:
C
C   Total number of name/ID mappings: 414
C
C   ID to name mappings.
C   -550                                 | M96
C   -550                                 | MARS 96
C   -550                                 | MARS-96
C   -550                                 | MARS96
C   -254                                 | MER-2
C   -253                                 | MER-1
C
C     ..                                   ..
C
C   50000020                             | SHOEMAKER-LEVY 9-B
C   50000021                             | SHOEMAKER-LEVY 9-A
C   50000022                             | SHOEMAKER-LEVY 9-Q1
C   50000023                             | SHOEMAKER-LEVY 9-P2
C
C   Name to ID mappings.
C   1978P1                               | 901
C   1979J1                               | 515
C
C     ..                                   ..
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     F.S. Turner    (JPL)
C     E.D. Wright    (JPL)
C
C$ Version
C
C-    SPICELIB Version 2.1.1, 27-FEB-2007 (EDW)
C
C        Completed the ZZBODLST declarations section.
C
C-    SPICELIB Version 2.1.0, 17-MAR-2003 (EDW)
C
C        Added a call to ZZIDMAP to retrieve the default
C        mapping list. "zzbodtrn.inc" no longer
C        contains the default mapping list.
C
C-    SPICELIB Version 2.0.0, 23-AUG-2002 (FST)
C
C        This entry point was moved into ZZBODBLT and some
C        variable names were changed to refer to variables
C        in the umbrella.
C
C-    SPICELIB Version 1.0.0, 26-NOV-2001 (EDW)
C
C-&

      IF ( RETURN() ) THEN
         RETURN
      ELSE
         CALL CHKIN ( 'ZZBODLST' )
      END IF

C
C     Upper case the ZZRQST value.
C
      CALL UCASE  ( REQST, ZZRQST )
      CALL INTSTR ( NPERM, ZZINT  )

      ZZLINE = 'Total number of name/ID mappings: '//ZZINT

      CALL WRLINE ( DEVICE, ZZLINE(1: LASTNB( ZZLINE ) ) )

C
C     Retrieve the current set of name/ID mappings
C
      CALL ZZIDMAP( BLTCOD, BLTNAM )

C
C      Branch as defined by the value of ZZRQST. 'ID' or 'BOTH'.
C
      IF ( EQSTR( ZZRQST , 'ID') .OR. EQSTR( ZZRQST , 'BOTH') ) THEN

         CALL ORDERI ( BLTCOD, NPERM, ZZOCOD )

         CALL WRLINE ( DEVICE, ' ' )
         CALL WRLINE ( DEVICE, 'ID to name mappings.' )

         DO I = 1, NPERM

            CALL INTSTR ( BLTCOD(ZZOCOD(I)) , ZZINT )

            ZZLINE = ZZINT // ' | ' // BLTNAM(ZZOCOD(I))

            CALL WRLINE ( DEVICE, ZZLINE(1: LASTNB( ZZLINE ) ) )

         END DO

      END IF

C
C     ... 'NAME' or 'BOTH'.
C
      IF ( EQSTR( ZZRQST, 'NAME') .OR. EQSTR( ZZRQST, 'BOTH') ) THEN

         CALL ORDERC ( BLTNAM, NPERM, ZZONAM )

         CALL WRLINE ( DEVICE, ' ' )
         CALL WRLINE ( DEVICE, 'Name to ID mappings.' )

         DO I = 1, NPERM

            CALL INTSTR ( BLTCOD(ZZONAM(I)) , ZZINT )

            ZZLINE = BLTNAM(ZZONAM(I)) // ' | ' // ZZINT

            CALL WRLINE ( DEVICE, ZZLINE(1:LASTNB( ZZLINE ) ) )

         END DO

      END IF

      CALL CHKOUT ( 'ZZBODLST' )
      RETURN

      END

max_stars_repo_name: agforero/FTFramework

max_issues_repo_name: agforero/fortran-testing-framework

max_forks_repo_name: agforero/fortran-testing-framework


text:
************************************************************************
*
*     Subroutine PPORDER                          Called by: PPCCTEST
*
*     return the index (IX) to put the censored data in sequential order
*
************************************************************************
      SUBROUTINE PPORDER(CENSFLAG,RESPPCC,NOBSC,IX)
*
*     subroutine arguments
*
      LOGICAL CENSFLAG(*)
      INTEGER*4 NOBSC,IX(*)
      DOUBLE PRECISION RESPPCC(*)
*
*     local vars
*
      INTEGER*4 I,INDX,L(0:NOBSC),P(0:NOBSC),R(0:NOBSC)
*
*     check to see if we have ordered data to begin with; if sorted, set
*     IX and return
*
      DO 50 I=2,NOBSC
         IX(I) = I
         IF (RESPPCC(I) .LT. RESPPCC(I-1)) GOTO 1
         IF (RESPPCC(I).EQ.RESPPCC(I-1) .AND.
     &      (CENSFLAG(I) .AND. .NOT. CENSFLAG(I-1))) GOTO 1
 50   CONTINUE
      IX(1) = 1
      RETURN
*
*     data is not ordered, set IX for sorted residuals
*
 1    L(1) =  0
      R(1) =  0
      P(1) =  0
      DO 10 I=2,NOBSC
         INDX = 1
         L(I) = 0
         R(I) = 0
 20      IF (RESPPCC(I).GT.RESPPCC(INDX) .OR.
     &      ((RESPPCC(I).EQ.RESPPCC(INDX)) .AND.
     &      (CENSFLAG(INDX).OR.(.NOT. CENSFLAG(I) .AND.
     &      .NOT. CENSFLAG(INDX))))) THEN
            IF(R(INDX) .EQ. 0) THEN
               R(INDX) = I
               P(I) = INDX
               GOTO 10
            ELSE
               INDX = R(INDX)
               GOTO 20
            ENDIF
         ELSE
            IF(L(INDX) .EQ. 0) THEN
               L(INDX) = I
               P(I) = INDX
               GOTO 10
            ELSE
               INDX = L(INDX)
               GOTO 20
            ENDIF
         ENDIF
 10   CONTINUE

      INDX = 1

      DO 40 I=1,NOBSC
 30      IF (L(INDX) .EQ. 0) THEN
            IX(I) = INDX
            P(R(INDX)) = P(INDX)
            L(P(INDX)) = R(INDX)
            INDX = P(INDX)
         ELSE
            INDX = L(INDX)
            GOTO 30
         ENDIF
 40   CONTINUE

      RETURN
      END

max_stars_repo_name: lthiamodelers/baseflow-coefficients

max_issues_repo_name: lthiamodelers/baseflow-coefficients

max_forks_repo_name: lthiamodelers/baseflow-coefficients


text:
        subroutine idz_matmulta(l,m,a,n,b,c)
c
c       multiplies a and b^* to obtain c.
c
c       input:
c       l -- first dimension of a and c
c       m -- second dimension of a and b
c       a -- leftmost matrix in the product c = a b^*
c       n -- first dimension of b and second dimension of c
c       b -- rightmost matrix in the product c = a b^*
c
c       output:
c       c -- product of a and b^*
c
        implicit none
        integer l,m,n,i,j,k
        complex*16 a(l,m),b(n,m),c(l,n),sum
c
c
        do i = 1,l
          do k = 1,n
c
            sum = 0
c
            do j = 1,m
              sum = sum+a(i,j)*conjg(b(k,j))
            enddo ! j
c
            c(i,k) = sum
c
          enddo ! k
        enddo ! i
c
c
        return
        end
c
c
c
c

max_stars_repo_name: ZhekehZ/catboost

max_issues_repo_name: birichie/catboost

max_forks_repo_name: birichie/catboost


text:
Describe Users/JayChou here.
Welcome to the Wiki, Jay.  Changing the attribution on your comment, like you did on the Wake Forest Apartments page, makes it seem like youre trying to disguise yourself, since readers cant see who left the comment.  Its also a bit Shadiness Factor shady to make it look like youre speaking for the Wake Forest management, when clearly you arent part of it anymore.  In what way did you work for them? Users/TomGarberson

20101119 23:33:25 nbsp Again, Jay.  Whats up with pretending to be Wake Forest Management? Users/TomGarberson