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

Go to the source code of this file.

Functions/Subroutines

subroutine hm_read_mpc (rbuf, ibufnc, ibufnn, ibufdl, ibufsk, iskn, itab, itabm, lag_ncf, lag_nkf, lag_nhf, ikine, ikine1lag, nom_opt, itagnd, lsubmodel, unitab)
subroutine hm_read_mpc0 (len, lsubmodel)

Function/Subroutine Documentation

◆ hm_read_mpc()

subroutine hm_read_mpc ( rbuf,
integer, dimension(*) ibufnc,
integer, dimension(*) ibufnn,
integer, dimension(*) ibufdl,
integer, dimension(*) ibufsk,
integer, dimension(liskn,*) iskn,
integer, dimension(*) itab,
integer, dimension(*) itabm,
integer lag_ncf,
integer lag_nkf,
integer lag_nhf,
integer, dimension(*) ikine,
integer, dimension(*) ikine1lag,
integer, dimension(lnopt1,*) nom_opt,
integer, dimension(*) itagnd,
type(submodel_data), dimension(*), intent(in) lsubmodel,
type(unit_type_), intent(in) unitab )

Definition at line 45 of file hm_read_mpc.F.

49C-----------------------------------------------
50 USE r2r_mod
51 USE message_mod
52 USE submodel_mod
53 USE hm_option_read_mod
54 USE unitab_mod
55 USE names_and_titles_mod , ONLY : nchartitle, ncharkey
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 "sphcom.inc"
66#include "param_c.inc"
67#include "units_c.inc"
68#include "r2r_c.inc"
69C-----------------------------------------------
70C D u m m y A r g u m e n t s
71C-----------------------------------------------
72 INTEGER LAG_NCF, LAG_NKF, LAG_NHF, ITAB(*), ITABM(*),
73 . ISKN(LISKN,*),IBUFNC(*),IBUFNN(*),IBUFDL(*),IBUFSK(*),
74 . IKINE(*),IKINE1LAG(*),ITAGND(*)
75 my_real :: rbuf(*)
76 INTEGER NOM_OPT(LNOPT1,*)
77 TYPE(UNIT_TYPE_),INTENT(IN) ::UNITAB
78 TYPE(SUBMODEL_DATA), DIMENSION(*),INTENT(IN) :: LSUBMODEL
79C-----------------------------------------------
80C L o c a l V a r i a b l e s
81C-----------------------------------------------
82 INTEGER I, II, J, ID, NOD, IDDL, ISKW, NUMC, KF, NOSYS, NMP
83 my_real coef
84 CHARACTER(LEN=NCHARTITLE) :: TITR
85 CHARACTER(LEN=NCHARKEY) :: KEY
86 CHARACTER :: MESS*40
87 DATA mess/'MULTI-POINT CONSTRAINTS '/
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 USR2SYS
93C======================================================================|
94 WRITE(iout,1000)
95
96 is_available = .false.
97C
98 CALL hm_option_start('/MPC')
99C
100 kf = 0
101 nmp = 0
102 DO i=1,nummpc
103 nmp=nmp+1
104C----------Multidomaines --> on ignore les mpc non tages----------
105 IF(nsubdom>0)THEN
106 IF(tagmpc(nmp)==0)CALL hm_sz_r2r(tagmpc,nmp,lsubmodel)
107 END IF
108C-----------------------------------------------------------------
109 CALL hm_option_read_key(lsubmodel,
110 . option_id = id,
111 . option_titr = titr,
112 . keyword2 = key)
113
114 nom_opt(1,i)=id
115 CALL fretitl(titr,nom_opt(lnopt1-ltitr+1,i),ltitr)
116C
117 CALL hm_get_intv('number_of_nodes',numc,is_available,lsubmodel)
118 DO ii=1,numc
119 CALL hm_get_int_array_index('node_ID',nod,ii,is_available,lsubmodel)
120 CALL hm_get_int_array_index('Idof',iddl,ii,is_available,lsubmodel)
121 CALL hm_get_int_array_index('skew_ID',iskw,ii,is_available,lsubmodel)
122 CALL hm_get_float_array_index('alpha',coef,ii,is_available,lsubmodel,unitab)
123 kf = kf + 1
124 IF (coef==zero) coef = one
125 rbuf(kf) = coef
126 nosys = usr2sys(nod,itabm,mess,id)
127 IF (ns10e>0) THEN
128 IF(itagnd(nosys)/=0) THEN
129C------- error out
130 CALL ancmsg(msgid=1208,
131 . msgtype=msgerror,
132 . anmode=aninfo_blind_1,
133 . i1=itab(nosys),
134 . c1='MPC ',
135 . i2=id,
136 . c2='MPC ')
137 ENDIF
138 END IF
139 CALL kinset(512,itab(nosys),ikine(nosys),7,0,ikine1lag(nosys))
140 ibufnn(kf) = nosys
141 CALL ifrontplus(nosys,1)
142 ibufdl(kf) = iddl
143 ibufsk(kf) = 0
144 DO j=0,numskw+min(1,nspcond)*numsph+nsubmod
145 IF(iskw==iskn(4,j+1)) THEN
146 ibufsk(kf) = j+1
147 GO TO 10
148 ENDIF
149 ENDDO
150 CALL ancmsg(msgid=137,anmode=aninfo,msgtype=msgerror,
151 . c1='MPC',
152 . c2='MPC',
153 . i1=id,i2=iskw,c3=titr)
154 10 CONTINUE
155 IF (iskw==0) THEN
156 lag_nkf = lag_nkf + 1
157 ELSE
158 lag_nkf = lag_nkf + 3
159 ENDIF
160 ENDDO
161 ibufnc(i) = numc
162 WRITE(iout,1101) id,numc
163 WRITE(iout,1102) (itab(ibufnn(j)),ibufdl(j),iskn(4,ibufsk(j)),rbuf(j),
164 . j=kf-numc+1,kf)
165 ENDDO
166C---
167 lag_nhf = lag_nhf + nummpc*(nummpc-1)
168 lag_ncf = lag_ncf + nummpc
169C---
170 RETURN
171 1000 FORMAT(//
172 .' MULTI-POINT CONSTRAINTS '/
173 . ' ---------------------- ')
174 1101 FORMAT( 10x,'MPC ID. . . . . . . . . . . . . .',i10
175 . /10x,'NUMBER OF POINTS. . . . . . . . .',i10
176 . /10x,'CONSTRAINT LIST :'
177 . /5x, ' NODE DDL SKEW COEFFICIENT'/)
178 1102 FORMAT( 3i10,1pg20.13/)
179C---
180 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
ifrontplus
subroutine ifrontplus(n, p)
Definition frontplus.F:100
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_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_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
kinset
subroutine kinset(ik, node, ikine, idir, isk, ikine1)
Definition kinset.F:57
min
#define min(a, b)
Definition macros.h:20
id
initmumps id
Definition multiplerhs_example.m:4
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
names_and_titles_mod::ncharkey
integer, parameter ncharkey
Definition names_and_titles_mod.F:1000
r2r_mod
Definition r2r_mod.F:125
r2r_mod::tagmpc
integer, dimension(:), allocatable tagmpc
Definition r2r_mod.F:140
submodel_mod
Definition submodel_mod.F:712
submodel_mod::nsubmod
integer nsubmod
Definition submodel_mod.F:720
unitab_mod
Definition unitab_mod.F:513
hm_sz_r2r
subroutine hm_sz_r2r(tag, val, lsubmodel)
Definition routines_r2r.F:300
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
usr2sys
integer function usr2sys(iu, itabm1, mess, id)
Definition sysfus.F:160

◆ hm_read_mpc0()

subroutine hm_read_mpc0 ( integer len,
type(submodel_data), dimension(*), intent(in) lsubmodel )

Definition at line 196 of file hm_read_mpc.F.

197C-----------------------------------------------
198 USE submodel_mod
199 USE hm_option_read_mod
200 USE names_and_titles_mod , ONLY : nchartitle
201C-----------------------------------------------
202C I m p l i c i t T y p e s
203C-----------------------------------------------
204#include "implicit_f.inc"
205C-----------------------------------------------
206C C o m m o n B l o c k s
207C-----------------------------------------------
208#include "param_c.inc"
209C-----------------------------------------------
210C D u m m y A r g u m e n t s
211C-----------------------------------------------
212 INTEGER LEN
213 TYPE(SUBMODEL_DATA), DIMENSION(*) ,INTENT(IN) :: LSUBMODEL
214C-----------------------------------------------
215C L o c a l V a r i a b l e s
216C-----------------------------------------------
217 INTEGER I, ID, NUMC
218 CHARACTER(LEN=NCHARTITLE) :: TITR
219 LOGICAL IS_AVAILABLE
220C======================================================================|
221 is_available = .false.
222C
223 ! Start reading /MPC card
224 CALL hm_option_start('/MPC')
225
226 len = 0
227 DO i=1,nummpc
228 CALL hm_option_read_key(lsubmodel,
229 . option_id = id,
230 . option_titr = titr)
231C
232 CALL hm_get_intv('number_of_nodes',numc,is_available,lsubmodel)
233 len = len+numc
234 ENDDO
235C---
236 RETURN