Télécharger manuc7.eso

Retour à la liste

Numérotation des lignes :

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

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