1C***********************************************************************
2C LHS (Latin Hypercube Sampling) UNIX Library/Standalone.
3C Copyright (c) 2004, Sandia Corporation.  Under the terms of Contract
4C DE-AC04-94AL85000 with Sandia Corporation, the U.S. Government
5C retains certain rights in this software.
6C
7C This software is distributed under the GNU Lesser General Public License.
8C For more information, see the README file in the LHS directory.
9C***********************************************************************
10C     Last change:  SLD  11 Jul 101   11:11 am
11!LHS_EXPORT_DEC ATTRIBUTES DLLEXPORT::LHS_CONST
12      SUBROUTINE LHS_CONST(NAMVAR,PTVAL,IError,IPVNO)
13c     LHS_CONST inputs data for a user-defined "constant" distribution
14c     LHS_CONST calls routines: LJUST
15c
16c   Descriptions of call list parameters:
17c   Inputs:
18c     NAMVAR = name of the variable
19c     PTVAL = real point value "constant" associated with NAMVAR
20c   Outputs:
21c     IError = error flag, returned = 1 to indicate some error occurred
22c     IPVNO = point value index number
23c
24      USE KILLFILE
25      USE PARMS
26c     PARMS provides: NamLen,MAXTB,LENC
27      USE CPARAM
28c     CPARAM provides: IptVal, List, IVarNm, IDIST arrays
29      USE InByCall
30cc    InByCall provides subroutine flags: LINT,LPREP,LDIST,NNames,IScrh6
31      USE DISTNM
32c     DISTNM provides:  DIST,IDSST,IDSEND,IDSPAR,LEND,MAXPAR
33c
34      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35c     Call List Variables:
36      INTEGER :: IPVNO,IError
37      CHARACTER(LEN=*) :: NAMVAR
38      DOUBLE PRECISION :: PTVAL
39c
40c     LHS Internal Variables:
41      CHARACTER(LEN=NamLen) :: Name
42CCCC      CHARACTER(LEN=35) :: NamVal
43cc    CHARACTER(LEN=32768) :: LCard, > dimension was needed in RDPAR2
44      CHARACTER(LEN=40) :: LCard
45CCCC      Character Card*(LENC)
46cccc      LOGICAL Err  used in RDPAR2 to track multiple error conditions
47c
48c
49c  check to see if message file is open,
50c    if not then open as a scratch file
51      IF (IScrh6 == 0) THEN
52c        Open scratch file, S6
53         OPEN(4, FILE='S4', Form='FORMATTED')
54c    3 Carriage Control='FORTRAN')
55         IScrh6 = 1
56      END IF
57c
58c Check to see that INIT has been called and PREP has not
59c     Test that LHS_INIT has been called
60      IF (LINIT /= 1) THEN
61         KLLERR = .TRUE.
62         IError = 1
63         WRITE(*,9006)
64         WRITE (99,9006)
65         WRITE(4,9006)
66         Return
67      END IF
68c     Test that LHS_PREP has not been called prematurely
69      IF (LPREP /= 0) THEN
70         KLLERR = .TRUE.
71         IError = 1
72         WRITE(*,9001)
73         WRITE (99,9001)
74         WRITE(4,9001)
75         Return
76      END IF
77c
78c  check to be sure NAMVAR is <= 16 characters and not all blanks
79c  terminate trailing blanks; eliminate any leading blanks
80      LCard = NAMVAR
81      LCard = TRIM(LCard)
82      Call LJust(LCard)
83      IL = LEN_TRIM(LCard)
84      IF (IL == 0) THEN
85         KLLERR = .TRUE.
86         IError = 1
87         WRITE(*,9040)
88         WRITE(99,9040)
89         WRITE(4,9040)
90         Return
91      END IF
92      IF (IL > NamLen) THEN
93         KLLERR = .TRUE.
94         IError = 1
95         WRITE(*,9010) NAMVAR
96         WRITE(99,9010) NAMVAR
97         WRITE(4,9010) NAMVAR
98         Return
99      END IF
100      NAME = LCard
101c
102cccc Following section from RDPAR2
103cccc these variables appear in section of code:
104c       Err = flag used for tracking when editing multiple errors
105c       Err is not needed for LHS_DIST routine
106c       IVFnd = 0 or 1, Flag for point value present=1, or not=0
107c       NNames is initialized in LHS_INIT and used by other
108c          LHS_Distribution subroutines through module InByCall
109c
110c        -- check the name against the existing list of names
111c
112         IFound = 0
113         Do i=1, NNames
114            If ( Name == List(i) ) Then
115               IFound = 1
116               IList = i
117               If (IVarNm(i) /= 0) Then
118cccc  Following section modified:
119c                 -- duplicate definition found
120cccc                  Print *, 'Multiple definitions found for ', Name
121c****** add prints to message and error files
122cccc                  Write(99,*) 'Multiple definitions found for ', Name
123cccc                  Write(4,*) 'Multiple definitions found for ', Name
124c******
125cccc                  Err = .True.
126                  IError = 1
127                  KLLERR = .TRUE.
128                  WRITE(*,9015) Name
129                  WRITE(4,9015) Name
130                  WRITE(99,9015) Name
131                  Return
132cccc  end of modification
133               End If
134               Exit
135            End If
136         End Do
137c        -- If name not found in list, add to the list
138         If (IFound == 0) Then
139            NNames = NNames + 1
140            IList = NNames
141            List(IList) = Name
142         End If
143c
144c        -- If no point value found and LHSPVAL 0 is specified, then
145c        -- declare an error and stop.
146c
147cccc following section omitted as it was checked on input to this routine
148cccc         If ( IPtVal == 0  .AND.  IVFnd == 0 ) Then
149cccc            Print *, 'Error: When the keyword LHSPVAL 0 is present, ',
150cccc     1               'all point values must be specified.'
151cccc            Print *, 'Point value missing for ', Name
152c****** add prints to message and error files
153cccc            Write(99,*) 'Error: When the keyword LHSPVAL 0 is ',
154cccc     1               'present, all point values must be specified.'
155cccc            Write(99,*) 'Point value missing for ', Name
156cccc            Write(4,*) 'Error: When the keyword LHSPVAL 0 is ',
157cccc     1               'present, all point values must be specified.'
158cccc            Write(4,*) 'Point value missing for ', Name
159c******
160cccc           Err = .True.
161cccc         End If
162c
163            Value = PTVAL
164c take "CONSTANT" loop from RDPAR2
165c        -- Check for the "Constant" distribution type
166c
167CCCC         If ( LCard(1:9) == 'CONSTANT ' ) Then
168            IVarNm(IList) = -9999999
169cc            Read (LCard(10:),*,Err=9000) Value                        sld01
170CCCC            Read (LCard(10:),*,Err=9000,END=9000) Value                 sld01
171CCCC            If ( IPtVal /= 0 ) PValue(IList) = Value
172c
173c LHS_CONST sets th point value to be the same as the constant value
174c regardless of what the LHSPVAL setting is !!!!!
175c Note: that this is different from the Standard LHS which will print
176c       a value different than the constant value for the point value
177c       if the user inputs something different from the constant
178c
179            PValue(IList) = Value
180c
181CCCC            Cycle
182CCCC         End If
183c
184c     Set the point value index number for return to LHS_CONST
185      IPVNO = IList
186      RETURN
187c
188 9040 FORMAT(//,5X,'Variable Name is all blanks')
189 9001 FORMAT('1',5X,'LHS_PREP has been called prematurely ',/,5X,
190     x'Call LHS_PREP just before call to LHS_RUN')
191 9006 FORMAT(//,5x,'LHS_INIT or LHS_INIT_MEM must be called before ',
192     x'any other LHS Input-By-Call Subroutines')
193 9010 FORMAT('1',5X,'Variable Name exceeds 16 characters, NAMVAR = '
194     x,A)
195 9015 FORMAT(//,5X, 'Multiple definitions found for ', A16)
196c
197      END SUBROUTINE
198