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