Télécharger manuc7.eso

Retour à la liste

Numérotation des lignes :

  1. C MANUC7 SOURCE CB215821 19/11/22 21:15:10 10387
  2.  
  3. *------------------------------------------------------------------
  4. *
  5. * CREATION D'UN MCHAML
  6. *
  7. *------------------------------------------------------------------
  8. *
  9. * PARAMETRES: (E)=ENTREE (S)=SORTIE
  10. * -----------
  11. *
  12. * IPMODL (E) POINTEUR DE L'OBJET MODELE
  13. * MODELE et SOUS-MODELE(S) ACTIFS EN ENTREE/SORTIE
  14. * MLMOTS (E) POINTEUR SUR UN LISTMOTS CONTENANT LES NOMS
  15. * ACTIF EN ENTREE/SORTIE
  16. * IPOI (E) POINTEUR SUR UN LISTENTI OU UN LISTREEL
  17. * MONMOT (E) MOT DE 8 CARACTERES
  18. * MLMOT3 (E) POINTEUR SUR UN LISTMOTS CONTENANT LES TYPES
  19. * MLMOT2 (E) POINTEUR SUR UN LISTMOTS CONTENANT LES TYPES
  20. * DES CONSTITUANTS
  21. * LETYP (E) TYPE DU MCHAML A CREER
  22. * JER1 (E) LONGUEUR DE LA CHAINE DE CARACTERES
  23. * ISUP1 (E) SUPPORT DEMANDE
  24. * ICHA (S) POINTEUR SUR LE MCHAML RESULTAT
  25. *
  26. * LANGAGE:
  27. * --------
  28. *
  29. * ESOPE + FORTRAN77
  30. *
  31. ************************************************************************
  32.  
  33. SUBROUTINE MANUC7(IPMODL,MLMOTS,IPOI,MONMOT,MLMOT3,MLMOT2,
  34. & LETYP,JER1,ISUP1,ICHA,itart)
  35.  
  36. IMPLICIT INTEGER(I-N)
  37. IMPLICIT REAL*8(A-H,O-Z)
  38.  
  39. -INC CCOPTIO
  40. -INC CCGEOME
  41.  
  42. -INC SMCHAML
  43. -INC SMELEME
  44. -INC SMLMOTS
  45. -INC SMLREEL
  46. -INC SMLENTI
  47. -INC SMMODEL
  48. -INC SMINTE
  49.  
  50. SEGMENT MPTVAL
  51. INTEGER IPOS(NS) ,NSOF(NS)
  52. INTEGER IVAL(NCOSOU)
  53. CHARACTER*16 TYVAL(NCOSOU)
  54. ENDSEGMENT
  55.  
  56. SEGMENT NOTYPE
  57. CHARACTER*16 TYPE(NBTYPE)
  58. ENDSEGMENT
  59.  
  60. SEGMENT INFO
  61. INTEGER INFELL(JG)
  62. ENDSEGMENT
  63. *
  64. PARAMETER ( N3 = 6 , NINF = 3 )
  65.  
  66. CHARACTER*(*) MONMOT, LETYP
  67.  
  68. CHARACTER*8 CHARIN
  69. CHARACTER*(NCONCH) CONM
  70. CHARACTER*4 CAR,CAR2
  71.  
  72. DIMENSION INFOS(NINF)
  73.  
  74. ICHA = 0
  75. ITHER= 0
  76. IDIFF= 0
  77. IMETA= 0
  78. ICHPH= 0
  79. *
  80. MMODEL = IPMODL
  81. NSOUS = mmodel.KMODEL(/1)
  82. *
  83. * Determination du nombre de sous-modeles (sous-zones) a traiter :
  84. NSZ1 = NSOUS
  85. DO i = 1, NSOUS
  86. IMODEL = mmodel.KMODEL(i)
  87. IF (imodel.NEFMOD.EQ.22) NSZ1 = NSZ1 - 1
  88. IF (imodel.NEFMOD.EQ.259) NSZ1 = NSZ1 - 1
  89. ENDDO
  90. *
  91. * INITIALISATION DU SEGMENT MCHELM
  92. *
  93. N1 = NSZ1
  94. L1 = JER1
  95. SEGINI,MCHELM
  96. mchelm.TITCHE = LETYP
  97. mchelm.IFOCHE = IFOUR
  98. N2 = mlmots.MOTS(/2)
  99.  
  100. IF (MONMOT.EQ.'REAL*8 ') THEN
  101. MLREEL = IPOI
  102. ELSE
  103. MLENTI = IPOI
  104. ENDIF
  105.  
  106. INFOS(1) = 0
  107. INFOS(2) = 0
  108. INFOS(3) = NIFOUR
  109. *
  110. * BOUCLE SUR LES ZONES ELEMENTAIRES DU MODELE
  111. *
  112. kch = 0
  113. DO 20 isous = 1, NSOUS
  114. *
  115. IMODEL = mmodel.KMODEL(isous)
  116. C
  117. C ON RECUPERE L INFORMATION GENERALE
  118. C
  119. IPMAIL = imodel.IMAMOD
  120. CONM = imodel.CONMOD
  121. C____________________________________________________________________
  122. C
  123. C INFORMATION SUR L'ELEMENT FINI
  124. C____________________________________________________________________
  125. C
  126. MELE = imodel.NEFMOD
  127. IF (MELE.EQ.22) GOTO 20
  128. IF (MELE.EQ.259) GOTO 20
  129. *
  130. NFOR = imodel.FORMOD(/2)
  131. CALL PLACE(imodel.FORMOD,NFOR,ITHER,'THERMIQUE')
  132. CALL PLACE(imodel.FORMOD,NFOR,IDIFF,'DIFFUSION')
  133. CALL PLACE(imodel.FORMOD,NFOR,IMETA,'METALLURGIE')
  134. CALL PLACE(imodel.FORMOD,NFOR,ICHPH,'CHANGEMENT_PHASE')
  135. CALL PLACE(imodel.FORMOD,NFOR,ICONT,'CONTACT')
  136. CALL PLACE(imodel.FORMOD,NFOR,IDARC,'DARCY')
  137. C
  138. C CAS DE LA FORMULATION DARCY ON VA EXTRAIRE LE MAILLAGE SOMMET
  139. C
  140. IF (IDARC.NE.0)THEN
  141. CALL LEKMOD(MMODEL,IPTABL,INEFMD)
  142. CHARIN = 'MAILLAGE'
  143. CALL LEKTAB(IPTABL,CHARIN, IOBRE)
  144. IF (IERR.NE.0) RETURN
  145. C* Inutile de reactiver le modele suite a LEKMOD :
  146. IPT1 = IOBRE
  147. IPMAIL= IOBRE
  148. c??? IF (NSZ1.GT.1) THEN
  149. IF (NSOUS.GT.1) THEN
  150. IPMAIL = IPT1.LISOUS(isous)
  151. ENDIF
  152. ENDIF
  153. C Fin du cas special DARCY
  154. *
  155. IPPORE = 0
  156. IF (MELE.GE.79.AND.MELE.LE.83) IPPORE = NBNNE(NUMGEO(MELE))
  157.  
  158. ISUP = ISUP1
  159. *
  160. * EN CAS DE FORMULATION CONTACT OU CHANGEMENT_PHASE, SEUL SUPPORT = LES NOEUDS
  161. * AM 25/1/08 ON FORCE LE SUPPORT EN CONSEQUENCE AU LIEU DE SORTIR EN ERREUR
  162. IF (ICONT.NE.0 .OR. ICHPH.NE.0) ISUP = 1
  163. *
  164. IPMIN = 0
  165. C MFR = 0
  166. info = 0
  167. IF (ISUP.NE.1) THEN
  168. IF (ITHER.EQ.0 .AND. IDIFF.EQ.0 .AND. IMETA.EQ.0) THEN
  169. IF (2+ISUP.GT.infmod(/1)) THEN
  170. CALL ELQUOI(MELE,0,ISUP,IPINF,IMODEL)
  171. IF (IERR.NE.0) GOTO 99
  172. info = IPINF
  173. IPMIN = info.INFELL(11)
  174. C MFR = info.INFELL(13)
  175. SEGSUP,info
  176. else
  177. IPMIN = infmod(ISUP+2)
  178. C MFR = INFELE(13)
  179. endif
  180. ELSE
  181. c en THERMIQUE, DIFFUSION, METALLURGIE, CHANGEMENT_PHASE on veut les points de gauss ad hoc
  182. nmat = imodel.matmod(/2)
  183. CALL PLACE(matmod,nmat,iray,'RAYONNEMENT')
  184. C Support 6 SAUF pour le RAYONNEMENT...
  185. C Les cas-tests de RAYONNEMENT sont en erreur sans ca...
  186. IF (iray.EQ.0) THEN
  187. ISUP = 6
  188. CALL TSHAPE(MELE,'GAUSS',IPMIN)
  189. ELSE
  190. NLG = NUMGEO(MELE)
  191. CALL TSHAPE(NLG,'GAUSS',IPMIN)
  192. ENDIF
  193. ENDIF
  194. ENDIF
  195. MINTE = IPMIN
  196.  
  197. kch = kch+1
  198. IMACHE(kch) = IPMAIL
  199. CONCHE(kch) = CONMOD
  200. INFCHE(kch,1) = 0
  201. INFCHE(kch,2) = 0
  202. INFCHE(kch,3) = NIFOUR
  203. INFCHE(kch,4) = IPMIN
  204. INFCHE(kch,5) = 0
  205. INFCHE(kch,6) = ISUP
  206.  
  207. SEGINI,MCHAML
  208. ICHAML(kch) = MCHAML
  209. *
  210. N1PTEL = 0
  211. N1EL = 0
  212. N2PTEL = 0
  213. N2EL = 0
  214.  
  215. IF (MONMOT.EQ.'REAL*8 ') THEN
  216. N1PTEL = 1
  217. N1EL = 1
  218. DO in = 1, N2
  219. SEGINI,MELVAL
  220. melval.VELCHE(N1PTEL,N1EL) = mlreel.PROG(in)
  221. mchaml.NOMCHE(in) = mlmots.MOTS(in)
  222. mchaml.TYPCHE(in) = MONMOT(1:6)
  223. mchaml.IELVAL(in) = MELVAL
  224. ENDDO
  225.  
  226. ELSE
  227.  
  228. DO 10 in = 1, N2
  229. mchaml.NOMCHE(in) = mlmots.MOTS(in)
  230. CAR = MLMOT3.MOTS(in)(1:4)
  231. CAR2 = MLMOT2.MOTS(in)(1:4)
  232. *
  233. * TRAITEMENT PARTICULIER POUR LE TYPE 'MCHAML'
  234. *---------------
  235. IF (CAR.EQ.'MCHA') THEN
  236. *
  237. * MODIF 02/94 POUR POUTRE A FIBRES
  238. * TEST SUR LES MAILLAGES POINTES
  239. *
  240. IPCHE1 = mlenti.LECT(in)
  241. MCHEL1 = IPCHE1
  242. NSOU1 = MCHEL1.ICHAML(/1)
  243. IDEM = 0
  244. DO 294 i = 1, NSOU1
  245. IF (IPMAIL.EQ.MCHEL1.IMACHE(i)) IDEM = 1
  246. 294 CONTINUE
  247. IF (IDEM.EQ.0) GO TO 295
  248. *
  249. CALL QUESUP(IPMODL,IPCHE1,ISUP,0,IRET1,IRET2)
  250. IF (IRET1.GT.1) THEN
  251. SEGSUP MCHAML
  252. GOTO 99
  253. ENDIF
  254.  
  255. MMODEL = IPMODL
  256.  
  257. NBROBL = 1
  258. NBRFAC = 0
  259. SEGINI NOMID
  260. MOTAUX = NOMID
  261. LESOBL(1)= mchaml.NOMCHE(in)
  262. NBTYPE = 1
  263. SEGINI,NOTYPE
  264. MOTYPE = NOTYPE
  265. TYPE(1) = ' '
  266. CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOTAUX,MOTYPE,
  267. $ 2,INFOS,3,IVAAUX)
  268. SEGSUP,NOTYPE
  269. IF (IERR.NE.0)THEN
  270. SEGSUP MCHAML
  271. GOTO 99
  272. ENDIF
  273. IF (IRET1.EQ.1) THEN
  274. CALL VALCHE(IVAAUX,1,IPMIN,IPPORE,MOTAUX,MELE)
  275. IF (IERR.NE.0) THEN
  276. MPTVAL = IVAAUX
  277. MELVA1 = IVAL(1)
  278. SEGSUP MPTVAL,MCHAML
  279. GOTO 99
  280. ENDIF
  281. ENDIF
  282. SEGSUP,NOMID
  283. MPTVAL = IVAAUX
  284. mchaml.TYPCHE(in) = TYVAL(1)
  285. MELVA1 = IVAL(1)
  286. SEGINI,MELVAL=MELVA1
  287. IELVAL(IN) = MELVAL
  288. IF (IRET1.EQ.1)THEN
  289. SEGSUP MELVA1
  290. ENDIF
  291. SEGSUP,MPTVAL
  292. GOTO 10
  293. 295 CONTINUE
  294. ENDIF
  295. *
  296. IF (itart.EQ.1 .AND. CAR.EQ.'LIST'
  297. $ .AND. CAR2.EQ.'REEL') THEN
  298. mchaml.TYPCHE(IN) = 'REAL*8 '
  299. ipt4 = ipmail
  300. N1EL = ipt4.num(/2)
  301. N1PTEL = 1
  302. N2PTEL = 0
  303. N2EL = 0
  304. SEGINI,MELVAL
  305. mlree2 = mlenti.lect(in)
  306. jg2 = mlree2.prog(/1)
  307. ia = 0
  308. do i = 1, n1el
  309. ia = ia+1
  310. IF (ia.GT.jg2) ia=1
  311. melval.velche(N1PTEL,i) = mlree2.prog(ia)
  312. enddo
  313. ELSE
  314. mchaml.TYPCHE(IN) = 'POINTEUR'//car//car2
  315. N1PTEL = 0
  316. N1EL = 0
  317. mlent2 = mlenti.lect(in)
  318. if (ITART.EQ.1.AND.car2(1:4).eq.'INT ') then
  319. ipt4 = ipmail
  320. N2EL = ipt4.num(/2)
  321. N2PTEL = 1
  322. SEGINI,MELVAL
  323. jg2 = mlent2.lect(/1)
  324. ia = 0
  325. do i = 1, n2el
  326. ia = ia+1
  327. IF (ia.GT.jg2) ia=1
  328. melval.ielche(N2PTEL,i) = mlent2.lect(ia)
  329. enddo
  330. else
  331. N2PTEL = 1
  332. N2EL = 1
  333. SEGINI,MELVAL
  334. melval.ielche(1,1) = mlent2
  335. endif
  336. ENDIF
  337. mchaml.IELVAL(IN) = MELVAL
  338.  
  339. 10 CONTINUE
  340. * ENDDO
  341. *
  342. ENDIF
  343.  
  344. 20 CONTINUE
  345. * ENDDO
  346.  
  347. 99 CONTINUE
  348. *
  349. IF (IERR.NE.0)SEGSUP,MCHELM
  350. ICHA = MCHELM
  351.  
  352. END
  353.  
  354.  
  355.  
  356.  
  357.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales