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

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