37
38
39
43 USE eos_param_mod , ONLY : eos_param_
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59#include "implicit_f.inc"
60
61
62
63 TYPE (UNIT_TYPE_),INTENT(IN) ::UNITAB
64 INTEGER IOUT,IUNIT
66 TYPE(SUBMODEL_DATA), DIMENSION(NSUBMOD), INTENT(IN) :: LSUBMODEL
67 INTEGER,INTENT(IN) :: IMIDEOS
68 TYPE(EOS_PARAM_),INTENT(INOUT) :: EOS_STRUCT
69
70
71
72#include "param_c.inc"
73
74
75
76 my_real :: p0, e0, psh, rho0,mu0,rhoi,rhor,g0,ssp0,dpdmu,df
77 my_real :: xscale_a, xscale_b, fscale_a, fscale_b
78 LOGICAL :: IS_ENCRYPTED, IS_AVAILABLE, IS_AVAILABLE_RHO0
79 INTEGER :: A_FUN_ID, B_FUN_ID
80
81
82
83 is_encrypted = .false.
84 is_available = .false.
85 is_available_rho0 = .false.
86
88
89 CALL hm_get_intv (
'A_FUNC' ,a_fun_id ,is_available,lsubmodel)
90 CALL hm_get_intv (
'B_FUNC' ,b_fun_id ,is_available,lsubmodel)
91
92 CALL hm_get_floatv(
'XscaleA', xscale_a, is_available,lsubmodel
93 CALL hm_get_floatv(
'XscaleB', xscale_b, is_available,lsubmodel,unitab)
94
95 CALL hm_get_floatv(
'FscaleA', fscale_a, is_available,lsubmodel,unitab)
96 CALL hm_get_floatv(
'FscaleB', fscale_b, is_available,lsubmodel,unitab)
97
100 CALL hm_get_floatv(
'Refer_Rho', rho0, is_available_rho0,lsubmodel,unitab)
101
102
103 IF(a_fun_id+b_fun_id == 0)THEN
104 CALL ancmsg(msgid=67,msgtype=msgerror,anmode=aninfo,
105 . i1=imideos,
106 . c1='/EOS/TABULATED',
107 . c2='NO INPUT FUNCTION')
108 ENDIF
109
110 IF(is_available_rho0 .AND. rho0 < zero)THEN
111 CALL ancmsg(msgid=67,msgtype=msgerror,anmode=aninfo,
112 . i1=imideos,
113 . c1='/EOS/TABULATED',
114 . c2='REFERENCE DENSITY MUST BE STRICTLY POSITIVE')
115 ENDIF
116
117
118 rhor = pm(1)
119 rhoi = pm(89)
120
121 IF(rho0 > zero) THEN
122 rhor = rho0
123 pm(1)= rho0
124 ELSE
125 rho0=rhor
126 ENDIF
127
128
129 IF(rhoi == zero)THEN
130 mu0 = zero
131 ELSE
132 IF(rhor /= zero)THEN
133 mu0 = rhoi/rhor-one
134 ELSE
135 mu0 = zero
136 ENDIF
137 ENDIF
138
139 IF(rhoi /= zero)THEN
140 df = rhor/rhoi
141 ELSE
142 df = zero
143 ENDIF
144
145 p0 = zero
146
147
148 ssp0 = zero
149 g0 = zero
150 rhoi = pm(89)
151 dpdmu = zero
152
154 IF(rhor > zero) ssp0 = sqrt((dpdmu
155
156
157 pm(23) = e0
158 pm(27) = ssp0
159 pm(32) = zero
160 pm(88) = psh
161 pm(31) = p0-psh
162 pm(104)= p0-psh
163
164 eos_struct%NUPARAM = 4
165 eos_struct%NIPARAM = 2
166 eos_struct%NFUNC = 0
167 eos_struct%NTABLE = 0
168 CALL eos_struct%CONSTRUCT()
169
170 eos_struct%UPARAM(1) = xscale_a
171 eos_struct%UPARAM(2) = xscale_b
172 eos_struct%UPARAM(3) = fscale_a
173 eos_struct%UPARAM(4) = fscale_b
174
175 eos_struct%IPARAM(1) = a_fun_id
176 eos_struct%IPARAM(2) = b_fun_id
177
178 eos_struct%E0 = e0
179 eos_struct%PSH = psh
180
181 WRITE(iout,1000)
182
183 IF(is_encrypted)THEN
184 WRITE(iout,'(5X,A,//)')'CONFIDENTIAL DATA'
185 ELSE
186 WRITE(iout,1500)a_fun_id,xscale_a,fscale_a,b_fun_id,xscale_b,fscale_b
187 IF(is_available_rho0)WRITE(iout,1501)pm(1)
188 ENDIF
189
190 RETURN
191 1000 FORMAT(
192 & 5x,' TABULATED EOS '
193 & 5x,' ------------- ',/)
194 1500 FORMAT(
195 & 5x,'FUNCTION A IDENTIFIER . . . . . . . . . .=',1pg20.13/,
196 & 5x,'XSCALE_A. . . . . . . . . . . . . . . . .=',1pg20.13/,
197 & 5x,'FSCALE_A. . . . . . . . . . . . . . . . .=',1pg20.13/,
198 & 5x,'FUNCTION B IDENTIFIER . . . . . . . . . .=',1pg20.13/,
199 & 5x,'XSCALE_B. . . . . . . . . . . . . . . . .=',1pg20.13/,
200 & 5x,'FSCALE_B. . . . . . . . . . . . . . . . .=',1pg20.13/,
201 & 5x,'E0. . . . . . . . . . . . . . . . . . . .=',1pg20.13/,
202 & 5x,'psh . . . . . . . . . . . . . . . . . . .=',1PG20.13)
203 1501 FORMAT(
204 & 5X,'eos reference density . . . . . . . . . .=',1PG20.13)
205
206 RETURN
207
subroutine hm_get_floatv(name, rval, is_available, lsubmodel, unitab)
subroutine hm_get_intv(name, ival, is_available, lsubmodel)
subroutine hm_option_is_encrypted(is_encrypted)
subroutine ancmsg(msgid, msgtype, anmode, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, r1, r2, r3, r4, r5, r6, r7, r8, r9, c1, c2, c3, c4, c5, c6, c7, c8, c9, prmode)