OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
hm_read_thgrsens.F
Go to the documentation of this file.
1Copyright> OpenRadioss
2Copyright> Copyright (C) 1986-2025 Altair Engineering Inc.
3Copyright>
4Copyright> This program is free software: you can redistribute it and/or modify
5Copyright> it under the terms of the GNU Affero General Public License as published by
6Copyright> the Free Software Foundation, either version 3 of the License, or
7Copyright> (at your option) any later version.
8Copyright>
9Copyright> This program is distributed in the hope that it will be useful,
10Copyright> but WITHOUT ANY WARRANTY; without even the implied warranty of
11Copyright> MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12Copyright> GNU Affero General Public License for more details.
13Copyright>
14Copyright> You should have received a copy of the GNU Affero General Public License
15Copyright> along with this program. If not, see <https://www.gnu.org/licenses/>.
16Copyright>
17Copyright>
18Copyright> Commercial Alternative: Altair Radioss Software
19Copyright>
20Copyright> As an alternative to this open-source version, Altair also offers Altair Radioss
21Copyright> software under a commercial license. Contact Altair to discuss further if the
22Copyright> commercial version may interest you: https://www.altair.com/radioss/.
23!||====================================================================
24!|| hm_read_thgrsens ../starter/source/output/th/hm_read_thgrsens.F
25!||--- called by ------------------------------------------------------
26!|| hm_read_thgrou ../starter/source/output/th/hm_read_thgrou.F
27!||--- calls -----------------------------------------------------
28!|| ancmsg ../starter/source/output/message/message.F
29!|| fretitl ../starter/source/starter/freform.F
30!|| fretitl2 ../starter/source/starter/freform.F
31!|| hm_get_int_array_index ../starter/source/devtools/hm_reader/hm_get_int_array_index.F
32!|| hm_get_intv ../starter/source/devtools/hm_reader/hm_get_intv.F
33!|| hm_thvarc ../starter/source/output/th/hm_read_thvarc.F
34!|| hord ../starter/source/output/th/hord.F
35!|| r2r_exist ../starter/source/coupling/rad2rad/routines_r2r.F
36!|| zeroin ../starter/source/system/zeroin.F
37!||--- uses -----------------------------------------------------
38!|| format_mod ../starter/share/modules1/format_mod.F90
39!|| message_mod ../starter/share/message_module/message_mod.F
40!|| submodel_mod ../starter/share/modules1/submodel_mod.F
41!||====================================================================
42 SUBROUTINE hm_read_thgrsens(SENSORS,
43 . ITYP ,KEY ,IGS ,LITHBUFMX,ITHBUF ,
44 . IAD ,IFI ,ITHGRP ,ITHVAR ,NVALL ,
45 . NVARE ,NVARG ,VARE ,VARG ,IVARG ,
46 . NSNE ,NVARABF ,LSUBMODEL)
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
352 END
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_read_thgrsens
subroutine hm_read_thgrsens(sensors, ityp, key, igs, lithbufmx, ithbuf, iad, ifi, ithgrp, ithvar, nvall, nvare, nvarg, vare, varg, ivarg, nsne, nvarabf, lsubmodel)
Definition hm_read_thgrsens.F:47
hord
subroutine hord(nel, nsel)
Definition hord.F:35
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
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
submodel_mod::submodel_data
Definition submodel_mod.F:723
zeroin
subroutine zeroin(n1, n2, ma)
Definition zeroin.F:47