OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
hm_read_thgrsens.F File Reference
#include "implicit_f.inc"
#include "scr17_c.inc"
#include "com04_c.inc"
#include "units_c.inc"
#include "param_c.inc"
#include "r2r_c.inc"
#include "tabsiz_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine hm_read_thgrsens (sensors, ityp, key, igs, lithbufmx, ithbuf, iad, ifi, ithgrp, ithvar, nvall, nvare, nvarg, vare, varg, ivarg, nsne, nvarabf, lsubmodel)

Function/Subroutine Documentation

◆ hm_read_thgrsens()

subroutine hm_read_thgrsens ( type (sensors_), intent(in) sensors,
integer, intent(in) ityp,
character*10, intent(in) key,
integer, intent(inout) igs,
integer, intent(in) lithbufmx,
integer, dimension(lithbufmx), intent(out) ithbuf,
integer, intent(inout) iad,
integer, intent(inout) ifi,
integer, dimension(nithgr), intent(inout) ithgrp,
integer, dimension(sithvar), intent(out) ithvar,
integer, intent(in) nvall,
integer, intent(in) nvare,
integer, intent(in) nvarg,
character*10, dimension(nvare), intent(in) vare,
character*10, dimension(nvarg), intent(in) varg,
integer, dimension(18,nvarg), intent(in) ivarg,
integer, intent(out) nsne,
integer, intent(inout) nvarabf,
type (submodel_data), dimension(nsubmod), intent(in) lsubmodel )

Definition at line 42 of file hm_read_thgrsens.F.

47C-----------------------------------------------
48C M o d u l e s
49C-----------------------------------------------
50 USE groupdef_mod
51 USE message_mod
52 USE submodel_mod
53 USE sensor_mod
54 USE names_and_titles_mod , ONLY : nchartitle
55 USE format_mod , ONLY : fmw_i_a
56C-----------------------------------------------
57C I m p l i c i t T y p e s
58C-----------------------------------------------
59#include "implicit_f.inc"
60C-----------------------------------------------
61C C o m m o n B l o c k s
62C-----------------------------------------------
63#include "scr17_c.inc"
64#include "com04_c.inc"
65#include "units_c.inc"
66#include "param_c.inc"
67#include "r2r_c.inc"
68#include "tabsiz_c.inc"
69C-----------------------------------------------
70C D u m m y A r g u m e n t s
71C-----------------------------------------------
72 INTEGER ,INTENT(IN) :: ITYP,NVARE,NVARG,LITHBUFMX,NVALL
73 INTEGER ,INTENT(OUT) :: NSNE
74 INTEGER ,INTENT(INOUT) :: IFI,IAD,IGS,NVARABF
75 INTEGER ,DIMENSION(NITHGR) ,INTENT(INOUT) :: ITHGRP
76 INTEGER ,DIMENSION(18,NVARG) ,INTENT(IN) :: IVARG
77 INTEGER ,DIMENSION(SITHVAR) ,INTENT(OUT) :: ITHVAR
78 INTEGER ,DIMENSION(LITHBUFMX) ,INTENT(OUT) :: ITHBUF
79 CHARACTER*10 ,INTENT(IN) :: VARE(NVARE),KEY,VARG(NVARG)
80 TYPE (SUBMODEL_DATA) ,DIMENSION(NSUBMOD) ,INTENT(IN) :: LSUBMODEL
81 TYPE (SENSORS_) ,INTENT(IN) :: SENSORS
82C-----------------------------------------------
83C L o c a l V a r i a b l e s
84C-----------------------------------------------
85 INTEGER J,I,ID,NNE,K,IAD0,IFITMP,NVAR,N,IAD1,IAD2,IDS,IDSMAX,IDS_OBJ1
86 CHARACTER(LEN=NCHARTITLE) :: TITR
87 LOGICAL, DIMENSION(:), ALLOCATABLE :: FOUND
88 LOGICAL IS_AVAILABLE
89C-----------------------------------------------
90C E x t e r n a l F u n c t i o n s
91C-----------------------------------------------
92 INTEGER HM_THVARC,R2R_EXIST
93c=======================================================================
94 is_available = .false.
95 nsne = 0
96 id = ithgrp(1) ! ID of the /TH/SENSOR
97 CALL fretitl2(titr,ithgrp(nithgr-ltitr+1),ltitr)
98 ithgrp(2) = ityp
99 ithgrp(3) = 0
100 ifitmp = ifi+1000
101c
102 ! Number of variables indicated by the user
103 CALL hm_get_intv('Number_Of_Variables',nvar,is_available,lsubmodel)
104
105 IF (nvar == 0) THEN
106 IF (ityp /= 120)
107 . CALL ancmsg(msgid=1109, msgtype=msgerror, anmode=aninfo_blind_1,
108 . i1=id ,
109 . c1=titr )
110 igs = igs - 1
111 ithgrp(1:nithgr) = 0
112c
113 ELSE ! NVAR > 0
114c
115 nvar = hm_thvarc(vare,nvare,ithbuf(iad),varg,nvarg,ivarg,nvall,id,titr ,lsubmodel)
116 ! Number of Objects IDs
117 CALL hm_get_intv('idsmax',idsmax,is_available,lsubmodel)
118 CALL hm_get_int_array_index('ids',ids_obj1,1,is_available,lsubmodel)
119
120 IF (idsmax > 0 .AND. ids_obj1 == 0) THEN
121 ! Filling tables
122 ithgrp(6) = nvar
123 ithgrp(7) = iad
124 iad = iad + nvar
125 ifi = ifi + nvar
126 nne = idsmax
127 ithgrp(4 )= nne
128 ithgrp(5) = iad
129 iad2 = iad + 3*nne
130 ithgrp(8) = iad2
131 CALL zeroin(iad,iad + 43*nne-1,ithbuf)
132 ALLOCATE (found(sensors%NSENSOR))
133 found(1:sensors%NSENSOR) = .false.
134 nne = 0
135C
136 idsmax = sensors%NSENSOR
137 DO k = 1,idsmax
138 ids = sensors%SENSOR_TAB(k)%SENS_ID
139 ! Loop over Objects IDs
140 IF (ids > 0) THEN
141 IF (nsubdom > 0) THEN
142 IF (r2r_exist(ityp,ids) == 0) cycle
143 ENDIF
144c
145 n = 0
146 DO j=1,sensors%NSENSOR
147 IF (ids == sensors%SENSOR_TAB(j)%SENS_ID) THEN
148 n = j
149 EXIT
150 ENDIF
151 ENDDO
152 IF (n == 0) THEN
153 CALL fretitl2(titr,ithgrp(nithgr-ltitr+1),ltitr)
154 CALL ancmsg(msgid=257, msgtype=msgwarning, anmode=aninfo_blind_1,
155 . i1=ithgrp(1),
156 . c1=titr,
157 . c2=key,
158 . i2=ids)
159 ELSE
160 IF (.NOT. found(n)) THEN
161 nne = nne + 1
162 nsne = nsne+1
163 ithbuf(iad) = n
164 iad = iad+1
165 found(n) = .true.
166 ELSE
167 CALL fretitl2(titr,ithgrp(nithgr-ltitr+1),ltitr)
168 CALL ancmsg(msgid=256, msgtype=msgwarning, anmode=aninfo_blind_1,
169 . i1=ithgrp(1),
170 . c1=titr,
171 . c2=key,
172 . i2=ids)
173 ENDIF
174 ENDIF
175 ENDIF
176 ENDDO
177c-----------------------------------------------------------------------
178 ithgrp(4) = nne
179 iad2 = ithgrp(5)+3*nne
180 ithgrp(8) = iad2
181 ifi = ifi+3*nne+40*nne
182 iad = ithgrp(5)
183c
184 DEALLOCATE(found)
185c
186 CALL hord(ithbuf(iad),nne)
187C
188 DO i=1,nne
189 n = ithbuf(iad)
190 ithbuf(iad+2*nne) = sensors%SENSOR_TAB(n)%SENS_ID
191 titr = sensors%SENSOR_TAB(n)%TITLE
192
193 CALL fretitl(titr,ithbuf(iad2),40)
194
195 iad = iad + 1
196 iad2= iad2+ 40
197 ENDDO
198C
199 iad = iad2
200C
201C=======================================================================
202C ABF FILES
203C=======================================================================
204 nvar=ithgrp(6)
205 iad0=ithgrp(7)
206 ithgrp(9)=nvarabf
207 DO j=iad0,iad0+nvar-1
208 DO k=1,10
209 ithvar((ithgrp(9)+(j-iad0)-1)*10+k)=ichar(vare(ithbuf(j))(k:k))
210 ENDDO
211 ENDDO
212 nvarabf = nvarabf + nvar
213C=======================================================================
214C PRINTOUT
215C=======================================================================
216 n = ithgrp(4)
217 iad1 = ithgrp(5)
218 nvar=ithgrp(6)
219 iad0=ithgrp(7)
220 iad2=ithgrp(8)
221 WRITE(iout,'(//)')
222 CALL fretitl2(titr,ithgrp(nithgr-ltitr+1),ltitr)
223 WRITE(iout,'(A,I10,3A,I3,A,I5,2A)')' TH GROUP:',ithgrp(1),',',trim(titr),',',nvar,' VAR',n, key,':'
224 WRITE(iout,'(A)')' -------------------'
225 WRITE(iout,'(10A10)')(vare(ithbuf(j)),j=iad0,iad0+nvar-1)
226 WRITE(iout,'(3A)')' ',key,' NAME '
227 DO k=iad1,iad1+n-1
228 CALL fretitl2(titr,ithbuf(iad2),40)
229 iad2=iad2+40
230 WRITE(iout,fmt=fmw_i_a) sensors%SENSOR_TAB(ithbuf(k))%SENS_ID,titr(1:40)
231 ENDDO
232C
233
234 ELSE
235c
236 ! Filling tables
237 ithgrp(6) = nvar
238 ithgrp(7) = iad
239 iad = iad + nvar
240 ifi = ifi + nvar
241 nne = idsmax
242 ithgrp(4 )= nne
243 ithgrp(5) = iad
244 iad2 = iad + 3*nne
245 ithgrp(8) = iad2
246 CALL zeroin(iad,iad + 43*nne-1,ithbuf)
247 ALLOCATE (found(sensors%NSENSOR))
248 found(1:sensors%NSENSOR) = .false.
249 nne = 0
250C
251 DO k = 1,idsmax
252 CALL hm_get_int_array_index('ids',ids,k,is_available,lsubmodel)
253
254 ! Loop over Objects IDs
255 IF (ids > 0) THEN
256 IF (nsubdom > 0) THEN
257 IF (r2r_exist(ityp,ids) == 0) cycle
258 ENDIF
259c
260 n = 0
261 DO j=1,sensors%NSENSOR
262 IF (ids == sensors%SENSOR_TAB(j)%SENS_ID) THEN
263 n = j
264 EXIT
265 ENDIF
266 ENDDO
267 IF (n == 0) THEN
268 CALL fretitl2(titr,ithgrp(nithgr-ltitr+1),ltitr)
269 CALL ancmsg(msgid=257, msgtype=msgwarning, anmode=aninfo_blind_1,
270 . i1=ithgrp(1),
271 . c1=titr,
272 . c2=key,
273 . i2=ids)
274 ELSE
275 IF (.NOT. found(n)) THEN
276 nne = nne + 1
277 nsne = nsne+1
278 ithbuf(iad) = n
279 iad = iad+1
280 found(n) = .true.
281 ELSE
282 CALL fretitl2(titr,ithgrp(nithgr-ltitr+1),ltitr)
283 CALL ancmsg(msgid=256, msgtype=msgwarning, anmode=aninfo_blind_1,
284 . i1=ithgrp(1),
285 . c1=titr,
286 . c2=key,
287 . i2=ids)
288 ENDIF
289 ENDIF
290 ENDIF
291 ENDDO
292c-----------------------------------------------------------------------
293 ithgrp(4) = nne
294 iad2 = ithgrp(5)+3*nne
295 ithgrp(8) = iad2
296 ifi = ifi+3*nne+40*nne
297 iad = ithgrp(5)
298c
299 DEALLOCATE(found)
300c
301 CALL hord(ithbuf(iad),nne)
302C
303 DO i=1,nne
304 n = ithbuf(iad)
305 ithbuf(iad+2*nne) = sensors%SENSOR_TAB(n)%SENS_ID
306 titr = sensors%SENSOR_TAB(n)%TITLE
307
308 CALL fretitl(titr,ithbuf(iad2),40)
309
310 iad = iad + 1
311 iad2= iad2+ 40
312 ENDDO
313C
314 iad = iad2
315C
316C=======================================================================
317C ABF FILES
318C=======================================================================
319 nvar=ithgrp(6)
320 iad0=ithgrp(7)
321 ithgrp(9)=nvarabf
322 DO j=iad0,iad0+nvar-1
323 DO k=1,10
324 ithvar((ithgrp(9)+(j-iad0)-1)*10+k)=ichar(vare(ithbuf(j))(k:k))
325 ENDDO
326 ENDDO
327 nvarabf = nvarabf + nvar
328C=======================================================================
329C PRINTOUT
330C=======================================================================
331 n = ithgrp(4)
332 iad1 = ithgrp(5)
333 nvar=ithgrp(6)
334 iad0=ithgrp(7)
335 iad2=ithgrp(8)
336 WRITE(iout,'(//)')
337 CALL fretitl2(titr,ithgrp(nithgr-ltitr+1),ltitr)
338 WRITE(iout,'(A,I10,3A,I3,A,I5,2A)')' TH GROUP:',ithgrp(1),',',trim(titr),',',nvar,' VAR',n, key,':'
339 WRITE(iout,'(A)')' -------------------'
340 WRITE(iout,'(10A10)')(vare(ithbuf(j)),j=iad0,iad0+nvar-1)
341 WRITE(iout,'(3A)')' ',key,' NAME '
342 DO k=iad1,iad1+n-1
343 CALL fretitl2(titr,ithbuf(iad2),40)
344 iad2=iad2+40
345 WRITE(iout,fmt=fmw_i_a) sensors%SENSOR_TAB(ithbuf(k))%SENS_ID,titr(1:40)
346 ENDDO
347C
348 END IF ! IDSMAX > 0 .AND. IDS_OBJ1 == 0
349 ENDIF ! NVAR > 0
350c-----------
351 RETURN
hm_get_int_array_index
subroutine hm_get_int_array_index(name, ival, index, is_available, lsubmodel)
Definition hm_get_int_array_index.F:164
hm_get_intv
subroutine hm_get_intv(name, ival, is_available, lsubmodel)
Definition hm_get_intv.F:523
hm_thvarc
integer function hm_thvarc(vare, nv, ivar, varg, nvg, ivarg, nv0, id, titr, lsubmodel)
Definition hm_read_thvarc.F:46
hord
subroutine hord(nel, nsel)
Definition hord.F:35
id
initmumps id
Definition multiplerhs_example.m:4
groupdef_mod
Definition groupdef_mod.F:662
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
nvar
integer function nvar(text)
Definition nvar.F:32
r2r_exist
integer function r2r_exist(typ, id)
Definition routines_r2r.F:346
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
fretitl2
subroutine fretitl2(titr, iasc, l)
Definition freform.F:804
zeroin
subroutine zeroin(n1, n2, ma)
Definition zeroin.F:47