OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
hm_read_funct.F File Reference
#include "implicit_f.inc"
#include "scr17_c.inc"
#include "units_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine hm_read_funct (npc, pld, nfunct, table, npts_alloc, nom_opt, funcrypt, unitab, lsubmodel)

Function/Subroutine Documentation

◆ hm_read_funct()

subroutine hm_read_funct ( integer, dimension(*) npc,
pld,
integer nfunct,
type(ttable), dimension(*) table,
integer npts_alloc,
integer, dimension(lnopt1,*) nom_opt,
integer, dimension(*) funcrypt,
type(unit_type_), intent(in) unitab,
type(submodel_data), dimension(nsubmod), intent(in) lsubmodel )

Definition at line 43 of file hm_read_funct.F.

45C-----------------------------------------------
46C M o d u l e s
47C-----------------------------------------------
48 USE table_mod
49 USE message_mod
50 USE submodel_mod
51 USE hm_option_read_mod
52 USE unitab_mod
53 USE names_and_titles_mod , ONLY : nchartitle
54C-----------------------------------------------
55C I m p l i c i t T y p e s
56C-----------------------------------------------
57#include "implicit_f.inc"
58C-----------------------------------------------
59C C o m m o n B l o c k s
60C-----------------------------------------------
61#include "scr17_c.inc"
62#include "units_c.inc"
63C-----------------------------------------------
64C D u m m y A r g u m e n t s
65C-----------------------------------------------
66 INTEGER NFUNCT, NPTS_ALLOC
67 INTEGER NPC(*),FUNCRYPT(*)
68 my_real pld(npts_alloc)
69 TYPE(TTABLE) TABLE(*)
70 INTEGER NOM_OPT(LNOPT1,*)
71 TYPE(SUBMODEL_DATA), DIMENSION(NSUBMOD), INTENT(IN) :: LSUBMODEL
72 TYPE(UNIT_TYPE_), INTENT(IN) :: UNITAB
73C-----------------------------------------------
74C L o c a l V a r i a b l e s
75C-----------------------------------------------
76 INTEGER I,J,L,FUNC_ID,NPTS,STAT,N,II,ISMOOTH
77 INTEGER :: IPYTHON ! is it a FUNCT_PYTHON
78 my_real time, funct, bid, f5(5)
79 my_real xscale,yscale,xshift,yshift
80 CHARACTER(LEN=NCHARTITLE) :: TITR
81 CHARACTER MESS*40,KEY*20
82 DATA mess/' FUNCTION & TABLES DEFINITION '/
83 LOGICAL :: IS_ENCRYPTED, IS_AVAILABLE
84 INTEGER :: NB_FUNCT, NB_FUNCT_SMOOTH, IPT, NPT
85C--------------------------------------------------
86C B e g i n n i n g o f S u b r o u t i n e
87C--------------------------------------------------
88 IF (nfunct == 0) RETURN
89
90 stat = 0
91
92 WRITE (iout,2000) nfunct
93
94! Initialization
95 is_encrypted = .false.
96 is_available = .false.
97
98 npc(1)=1
99 l =0
100C--------------------------------------------------
101C READING /FUNCT ( ISMOOTH = 0, IPYTHON = 0)
102C--------------------------------------------------
103 CALL hm_option_count('/FUNCT', nb_funct)
104 CALL hm_option_count('/FUNCT_SMOOTH', nb_funct_smooth)
105 IF (nb_funct > 0) THEN
106 CALL hm_option_start('/FUNCT')
107 DO i = 1, nb_funct
108c
109 CALL hm_option_read_key(lsubmodel,
110 . option_titr = titr,
111 . option_id = func_id,
112 . keyword1 = key)
113c
114 ismooth = 0
115 ipython = 0
116 IF(key(6:12) == '_SMOOTH') ismooth = 1
117 IF(key(6:12) == '_PYTHON') ipython = 1
118
119 IF(ismooth == 0 .AND. ipython == 0 ) THEN
120 CALL hm_option_is_encrypted(is_encrypted)
121 l = l + 1
122 CALL fretitl(titr,nom_opt(lnopt1-ltitr+1,l),ltitr)
123 nom_opt(1, l) = func_id
124 npc(nfunct + l + 1) = func_id
125 npc(2 * nfunct + l + 1) = ismooth
126 npc(l + 1) = npc(l)
127 npts = 0
128 WRITE(iout, 2100) func_id
129! Number of points
130 CALL hm_get_intv('numberofpoints', npt, is_available, lsubmodel)
131c
132 DO ipt = 1, npt
133 CALL hm_get_float_array_index('points', time, 2 * ipt - 1, is_available, lsubmodel, unitab)
134 CALL hm_get_float_array_index('points', funct, 2 * ipt, is_available, lsubmodel, unitab)
135 IF (.NOT. is_encrypted) THEN
136 WRITE(iout,'(3X,1PG20.13,2X,1G20.13)') time,funct
137 ENDIF
138 npts = npts + 1
139 pld(npc(l + 1)) = time
140 IF (npts > 1) THEN
141 IF (pld(npc(l+1)) <= pld(npc(l+1)-2)) THEN
142! Decreasing time line
143 CALL ancmsg(msgid = 156, msgtype = msgerror, anmode = aninfo_blind_1,
144 . i1 = func_id, c1 = titr, i2 = npts, i3 = npts-1)
145 ENDIF
146 ENDIF
147 npc(l + 1) = npc(l + 1) + 1
148 pld(npc(l + 1)) = funct
149 npc(l + 1) = npc(l + 1) + 1
150 ENDDO
151c
152 IF (npt < 2) THEN
153 CALL ancmsg(msgid=1874, msgtype=msgwarning, anmode=aninfo_blind_1,
154 . i1=func_id,
155 . c1=titr)
156 END IF
157c
158! build table structure
159 table(l)%NOTABLE=func_id
160 table(l)%NDIM =1
161!
162 ALLOCATE(table(l)%X(1),stat=stat)
163 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
164 . msgtype=msgerror,
165 . c1='TABLE')
166 ALLOCATE(table(l)%X(1)%VALUES(npts),stat=stat)
167 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
168 . msgtype=msgerror,
169 . c1='TABLE')
170 ALLOCATE(table(l)%Y,stat=stat) ! Y or Y(1) ?
171 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
172 . msgtype=msgerror,
173 . c1='TABLE')
174 ALLOCATE(table(l)%Y%VALUES(npts),stat=stat)
175 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
176 . msgtype=msgerror,
177 . c1='TABLE')
178!
179 DO n=1,npts
180 table(l)%X(1)%VALUES(n)=pld(npc(l)+2*n-2)
181 table(l)%Y%VALUES(n) =pld(npc(l)+2*n-1)
182 ENDDO
183 IF (is_encrypted) THEN
184 WRITE(iout,'(A)')'CONFIDENTIAL DATA'
185 funcrypt(l) = 1
186 ENDIF
187 ENDIF
188 ENDDO
189 ENDIF
190C--------------------------------------------------
191C READING /FUNCT_SMOOTH ( ISMOOTH = 1)
192C--------------------------------------------------
193 IF (nb_funct_smooth > 0) THEN
194 CALL hm_option_start('/FUNCT_SMOOTH')
195 DO i = 1, nb_funct_smooth
196c
197 CALL hm_option_read_key(lsubmodel,
198 . option_titr = titr,
199 . option_id = func_id,
200 . keyword1 = key)
201c
202 CALL hm_option_is_encrypted(is_encrypted)
203 ismooth = 1
204 l = l + 1
205 CALL fretitl(titr,nom_opt(lnopt1-ltitr+1,l),ltitr)
206 nom_opt(1, l) = func_id
207 npc(nfunct + l + 1) = func_id
208 npc(2 * nfunct + l + 1) = ismooth
209 npc(l + 1) = npc(l)
210 npts = 0
211 WRITE(iout, 2200) func_id
212c
213 CALL hm_get_floatv('A_SCALE_X' ,xscale ,is_available ,lsubmodel ,unitab)
214 CALL hm_get_floatv('F_SCALE_Y' ,yscale ,is_available ,lsubmodel ,unitab)
215 CALL hm_get_floatv('A_SHIFT_X' ,xshift ,is_available ,lsubmodel ,unitab)
216 CALL hm_get_floatv('F_SHIFT_Y' ,yshift ,is_available ,lsubmodel ,unitab)
217 IF (xscale == zero) xscale = one
218 IF (yscale == zero) yscale = one
219
220 WRITE (iout,2300)
221 IF (.NOT. is_encrypted)
222 . WRITE(iout,'(3X,1PG20.13,3(2X,1G20.13))') xscale,yscale,xshift,yshift
223 WRITE (iout,2400)
224
225! Number of points
226 CALL hm_get_intv('numberofpoints', npt, is_available, lsubmodel)
227c
228 DO ipt = 1, npt
229 CALL hm_get_float_array_index('points', time, 2 * ipt - 1, is_available, lsubmodel, unitab)
230 CALL hm_get_float_array_index('points', funct, 2 * ipt, is_available, lsubmodel, unitab)
231c
232 time = time * xscale + xshift
233 funct = funct * yscale + yshift
234c
235 IF (.NOT. is_encrypted) THEN
236 WRITE(iout,'(3X,1PG20.13,2X,1G20.13)') time,funct
237 ENDIF
238 npts = npts + 1
239 pld(npc(l + 1)) = time
240 IF (npts > 1) THEN
241 IF (pld(npc(l+1)) <= pld(npc(l+1)-2)) THEN
242! Decreasing time line
243 CALL ancmsg(msgid = 156, msgtype = msgerror, anmode = aninfo_blind_1,
244 . i1 = func_id, c1 = titr, i2 = npts, i3 = npts-1)
245 ENDIF
246 ENDIF
247 npc(l + 1) = npc(l + 1) + 1
248 pld(npc(l + 1)) = funct
249 npc(l + 1) = npc(l + 1) + 1
250 ENDDO
251c
252 IF (npt < 2) THEN
253 CALL ancmsg(msgid=1874, msgtype=msgwarning, anmode=aninfo_blind_1,
254 . i1=func_id,
255 . c1=titr)
256 END IF
257c
258! build table structure
259 table(l)%NOTABLE=func_id
260 table(l)%NDIM =1
261!
262 ALLOCATE(table(l)%X(1),stat=stat)
263 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
264 . msgtype=msgerror,
265 . c1='TABLE')
266 ALLOCATE(table(l)%X(1)%VALUES(npts),stat=stat)
267 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
268 . msgtype=msgerror,
269 . c1='TABLE')
270 ALLOCATE(table(l)%Y,stat=stat)
271 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
272 . msgtype=msgerror,
273 . c1='TABLE')
274 ALLOCATE(table(l)%Y%VALUES(npts),stat=stat)
275 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
276 . msgtype=msgerror,
277 . c1='TABLE')
278!
279 DO n=1,npts
280 table(l)%X(1)%VALUES(n)=pld(npc(l)+2*n-2)
281 table(l)%Y%VALUES(n) =pld(npc(l)+2*n-1)
282 ENDDO
283 IF (is_encrypted) THEN
284 WRITE(iout,'(A)')'CONFIDENTIAL DATA'
285 funcrypt(l) = 1
286 ENDIF
287 ENDDO
288 ENDIF
289
290C
291 RETURN
292C-----------------------------------------------------------------
2932000 FORMAT(//
294 . ' LOAD CURVES'/
295 . ' -----------'/
296 . ' NUMBER OF LOAD CURVES. . . . . . . . =',i10/)
2972100 FORMAT(/' LOAD CURVE ID . . . . . . . . . . . =',i10//
298 . ' X Y ')
2992200 FORMAT(/' LOAD SMOOTH CURVE ID . . . . . . . =',i10)
3002300 FORMAT(/' XSCALE YSCALE XSHIFT
301 . YSHIFT ')
3022400 FORMAT(/' X Y ')
my_real
#define my_real
Definition cppsort.cpp:32
hm_get_float_array_index
subroutine hm_get_float_array_index(name, rval, index, is_available, lsubmodel, unitab)
Definition hm_get_float_array_index.F:105
hm_get_floatv
subroutine hm_get_floatv(name, rval, is_available, lsubmodel, unitab)
Definition hm_get_floatv.F:415
hm_get_intv
subroutine hm_get_intv(name, ival, is_available, lsubmodel)
Definition hm_get_intv.F:523
hm_option_count
subroutine hm_option_count(entity_type, hm_option_number)
Definition hm_option_count.F:105
hm_option_is_encrypted
subroutine hm_option_is_encrypted(is_encrypted)
Definition hm_option_is_encrypted.F:284
hm_option_start
subroutine hm_option_start(entity_type)
Definition hm_option_start.F:251
hm_option_read_mod::hm_option_read_key
Definition hm_option_read_mod.F:410
hm_option_read_mod
Definition hm_option_read_mod.F:408
message_mod
Definition message_mod.F:1249
names_and_titles_mod
Definition names_and_titles_mod.F:997
names_and_titles_mod::nchartitle
integer, parameter nchartitle
Definition names_and_titles_mod.F:1003
submodel_mod
Definition submodel_mod.F:712
table_mod
Definition table_mod.F:112
unitab_mod
Definition unitab_mod.F:513
ancmsg
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)
Definition message.F:889
fretitl
subroutine fretitl(titr, iasc, l)
Definition freform.F:620