Télécharger soraba.eso

Retour à la liste

Numérotation des lignes :

  1. C SORABA SOURCE JC220346 18/12/04 21:16:17 9991
  2. ************************************************************************
  3. * NOM : soraba.eso
  4. * DESCRIPTION : Sortie d'un maillage au format .inp ABAQUS(TM)
  5. ************************************************************************
  6. * HISTORIQUE : 8/01/2010 : FANDEUR : création de la subroutine
  7. * HISTORIQUE : 7/06/2012 : JCARDO : l'argument MOT1 devient optionnel
  8. * + ajout de l'extension .inp
  9. * HISTORIQUE :
  10. ************************************************************************
  11. * Prière de PRENDRE LE TEMPS DE COMPLÉTER LES COMMENTAIRES
  12. * en cas de modification de ce sous-programme afin de faciliter
  13. * la maintenance !
  14. ************************************************************************
  15. * APPELÉ PAR : opérateur SORTir (prsort.eso)
  16. ************************************************************************
  17. * ENTRÉES :: aucune
  18. * SORTIES :: aucune (sur fichier uniquement)
  19. ************************************************************************
  20. * SYNTAXE (GIBIANE) :
  21. *
  22. * SORT 'ABAQ' MAIL1
  23. *
  24. ************************************************************************
  25.  
  26. SUBROUTINE SORABA
  27.  
  28. IMPLICIT INTEGER(I-N)
  29. IMPLICIT REAL*8(A-H,O-Z)
  30.  
  31.  
  32. -INC PPARAM
  33. -INC CCOPTIO
  34.  
  35. -INC SMCOORD
  36. -INC SMELEME
  37. -INC SMINTE
  38. -INC SMLENTI
  39. SEGMENT MLISEF.MLENTI
  40. -INC TMLNOMS
  41.  
  42. SEGMENT MCHAEF
  43. CHARACTER*16 LCHA16(MEF)
  44. ENDSEGMENT
  45.  
  46. SEGMENT ITAB(0)
  47. POINTEUR ITAB1.ITAB
  48.  
  49. SEGMENT IMAIL
  50. INTEGER I_OBJ(NBMAIL),I_MAI(NBMAIL),L_OBJ(NBMAIL)
  51. CHARACTER*16 C_OBJ(NBMAIL)
  52. ENDSEGMENT
  53.  
  54. SEGMENT MWRK
  55. INTEGER NOEELT(nbno)
  56. REAL*8 XEL(3,nbno)
  57. ENDSEGMENT
  58.  
  59. EXTERNAL LONG
  60.  
  61. CHARACTER*16 CHA16z,CODEEF
  62.  
  63. C= Nombre d'informations par maillage elementaire dans MLISEF
  64. PARAMETER (IN_EF=3)
  65.  
  66. C= Unite logique du fichier d'impression au format Abaqus(TM)
  67. PARAMETER (IUABA=66)
  68. CHARACTER*256 FicAba
  69. LOGICAL ZOPEN
  70.  
  71. C= Base de conversion des elements MASSIFS Cast3m vers Abaqus
  72. PARAMETER (NNOMAX=20,NEFMAX=12)
  73. DIMENSION lTypEF(NEFMAX),
  74. & lInver(NNOMAX,NEFMAX),lOrdre(NNOMAX,NEFMAX)
  75. CHARACTER*6 NomAba(NEFMAX)
  76.  
  77. C= Element : SEG2 SEG3 TRI3 QUA4 TRI6
  78. C= QUA8 TET4 PRI6 CUB8 TE10
  79. C= PR15 CU20
  80. DATA lTypEF / 2, 3, 4, 8, 6,
  81. & 10, 23, 16, 14, 24,
  82. & 17, 15 /
  83. DATA ((lInver(j,i),j=1,NNOMAX),i=1,NEFMAX)
  84. & / 2, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  85. & 3, 2, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  86. & 1, 3, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  87. & 1, 4, 3, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  88. & 1, 6, 5, 4, 3, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  89. & 1, 8, 7, 6, 5, 4, 3, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  90. & 1, 3, 2, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  91. & 4, 5, 6, 1, 2, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  92. & 5, 6, 7, 8, 1, 2, 3, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  93. & 1, 7,10, 9, 5, 6, 2, 8, 4, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  94. & 10,11,12,13,14,15, 7, 8, 9, 1, 2, 3, 4, 5, 6, 0, 0, 0, 0, 0,
  95. & 13,14,15,16,17,18,19,20, 9,10,11,12, 1, 2, 3, 4, 5, 6, 7, 8 /
  96. DATA ((lOrdre(j,i),j=1,NNOMAX),i=1,NEFMAX)
  97. & / 1, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  98. & 1, 3, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  99. & 1, 2, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  100. & 1, 2, 3, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  101. & 1, 3, 5, 2, 4, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  102. & 1, 3, 5, 7, 2, 4, 6, 8, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  103. & 1, 2, 3, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  104. & 1, 2, 3, 4, 5, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  105. & 1, 2, 3, 4, 5, 6, 7, 8, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  106. & 1, 3, 5,10, 2, 4, 6, 7, 8, 9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  107. & 1, 3, 5,10,12,14, 2, 4, 6,11,13,15, 7, 8, 9, 0, 0, 0, 0, 0,
  108. & 1, 3, 5, 7,13,15,17,19, 2, 4, 6, 8,14,16,18,20, 9,10,11,12 /
  109. DATA NomAba / '____ ','____ ','C__3 ','C__4 ','C__6 ',
  110. & 'C__8 ','C3D4 ','C3D6 ','C3D8 ','C3D10 ',
  111. & 'C3D15 ','C3D20 ' /
  112.  
  113. C===
  114. C 0 - Premieres initialisations
  115. C===
  116. idimp1=IDIM+1
  117. C= Liste des elements MASSIFS qui sont sauvegardes (suivant IDIM)
  118. IF (IDIM.EQ.3) THEN
  119. I_DEB=7
  120. I_FIN=12
  121. ELSE IF (IDIM.EQ.2) THEN
  122. I_DEB=3
  123. I_FIN=6
  124. IF (IFOUR.EQ.-2) THEN
  125. DO i=I_DEB,I_FIN
  126. NomAba(i)(2:3)='PS'
  127. ENDDO
  128. ELSE IF (IFOUR.GE.0) THEN
  129. DO i=I_DEB,I_FIN
  130. NomAba(i)(2:3)='AX'
  131. ENDDO
  132. ELSE
  133. DO i=I_DEB,I_FIN
  134. NomAba(i)(2:3)='PE'
  135. ENDDO
  136. ENDIF
  137. ELSE IF (IDIM.EQ.1) THEN
  138. I_DEB=1
  139. I_FIN=2
  140. ELSE
  141. CALL ERREUR(832)
  142. RETURN
  143. ENDIF
  144. C En cas d erreur sur le fichier de sortie (si non nul)
  145. IOS=0
  146.  
  147. C===
  148. C 1 - Lecture des arguments (obligatoires)
  149. C===
  150. C Lecture du maillage a sauvegarder
  151. CALL LIROBJ('MAILLAGE',MAIREF,1,IRETOU)
  152. IF (IERR.NE.0) RETURN
  153. *
  154. C Lecture du nom du fichier de sauvegarde (=> bypass de OPTI SORT)
  155. C (CONSERVE POUR COMPATIBILITE MAIS NON DOCUMENTE)
  156. CALL LIRCHA(FICABA,0,IRETOU)
  157. IF (IRETOU.EQ.0) THEN
  158. INQUIRE(UNIT=IOPER,OPENED=ZOPEN)
  159. IF (.NOT.ZOPEN) THEN
  160. CALL ERREUR(-212)
  161. WRITE(IOIMP,*) '(via OPTI "SORT")'
  162. MOTERR(1:8)='ABAQUS '
  163. CALL ERREUR(705)
  164. RETURN
  165. ENDIF
  166. INQUIRE(UNIT=IOPER,NAME=NOMFIC)
  167. CLOSE(UNIT=IOPER,STATUS='DELETE')
  168. *
  169. * Ajout de l'extension au nom du fichier
  170. CALL LENCHA(NOMFIC,LC)
  171. FICABA=NOMFIC(1:LC)
  172. IF (NOMFIC(LC-3:LC).NE.'.inp') FICABA(LC+1:LC+4)='.inp'
  173. ENDIF
  174.  
  175. *
  176. C= Prevoir des options supplementaires ?
  177.  
  178. WRITE(IOIMP,*)
  179. C===
  180. C 2 - Analyse de l objet MAILLAGE a sauvegarder
  181. C===
  182. WRITE(IOIMP,500) 'Analyse du MAILLAGE a sauvegarder'
  183. C Verification du type des elements du maillage
  184. C Determination du nombre d'elements du maillage
  185. MELEME=MAIREF
  186. SEGACT,MELEME
  187. NB_OBJ=LISOUS(/1)
  188. NB_EF=MAX(1,NB_OBJ)
  189. JG=IN_EF*NB_EF
  190. SEGINI,MLISEF
  191. MEF=NB_EF
  192. SEGINI,MCHAEF
  193. CODEEF='0000000000000000'
  194. NB_ELT=0
  195. IF (NB_OBJ.EQ.0) THEN
  196. i_z=ITYPEL
  197. DO i=I_DEB,I_FIN
  198. IF (i_z.EQ.lTypEF(i)) GOTO 1
  199. ENDDO
  200. CALL ERREUR(16)
  201. GOTO 900
  202. 1 CONTINUE
  203. MLISEF.LECT(1)=MELEME
  204. MLISEF.LECT(2)=i
  205. MLISEF.LECT(3)=NB_ELT
  206. MCHAEF.LCHA16(1)='EF_'//NomAba(i)
  207. CODEEF(1:1)='1'
  208. NB_ELT=NB_ELT+NUM(/2)
  209. ELSE
  210. k=1
  211. DO j=1,NB_OBJ
  212. IPT1=LISOUS(j)
  213. SEGACT,IPT1
  214. i_z=IPT1.ITYPEL
  215. DO i=I_DEB,I_FIN
  216. IF (i_z.EQ.lTypEF(i)) GOTO 2
  217. ENDDO
  218. CALL ERREUR(16)
  219. GOTO 900
  220. 2 CONTINUE
  221. MLISEF.LECT(k)=IPT1
  222. MLISEF.LECT(k+1)=i
  223. MLISEF.LECT(k+2)=NB_ELT
  224. MCHAEF.LCHA16(j)='EF_'//NomAba(i)
  225. CODEEF(j:j)='1'
  226. NB_ELT=NB_ELT+IPT1.NUM(/2)
  227. k=k+IN_EF
  228. ENDDO
  229. ENDIF
  230. C*I WRITE(IOIMP,501) 'Type EF =',NB_EF
  231. C Appel a TASSER pour mettre les noeuds a sauvegarder en premier
  232. WRITE(IOIMP,502) 'Appel a TASSER (etape longue)'
  233. SEGINI,ITAB
  234. ITAB(**)=MAIREF
  235. MELEME=MAIREF
  236. IF (NB_OBJ.NE.0) THEN
  237. DO i=1,NB_OBJ
  238. ITAB(**)=LISOUS(i)
  239. ENDDO
  240. ENDIF
  241. ipt8=0
  242. CALL TASSPO(ITAB,ICOLAC,ipt8,0)
  243. IF (ipt8.GT.0) SEGSUP,ipt8
  244. IF (IERR.NE.0) THEN
  245. SEGSUP,ITAB
  246. GOTO 900
  247. ENDIF
  248. SEGINI,ITAB1=ITAB
  249. CALL SUPPIL(ICOLAC,-1)
  250. C= ITAB a ete supprime apres l'appel a SUPPIL.
  251. ITAB=ITAB1
  252. IF (IERR.NE.0) THEN
  253. SEGSUP,ITAB
  254. GOTO 900
  255. ENDIF
  256. C= Suite a l'appel a TASSER, les points sont classes en commencant par
  257. C= ceux associes au MAILLAGE qui nous interesse. Il suffit de trouver
  258. C= le noeud de numero max. dans le MAILLAGE.
  259. WRITE(IOIMP,502) 'Determination du numero du noeud max.'
  260. IMAX=0
  261. DO i=1,NB_EF
  262. MELEME=MLISEF.LECT(IN_EF*(i-1)+1)
  263. SEGACT,MELEME
  264. nbnn=NUM(/1)
  265. DO j=1,NUM(/2)
  266. DO k=1,nbnn
  267. IMAX=MAX(IMAX,NUM(k,j))
  268. ENDDO
  269. ENDDO
  270. SEGDES,MELEME
  271. ENDDO
  272. C*I WRITE(IOIMP,501) 'Numero du noeud max. =',IMAX
  273. C Liste des objets MAILLAGEs eventuellement a sauvegarder (IMAIL)
  274. C= En sortie de TASSPO, ITAB a ete modifie et pointe sur tous les
  275. C= maillages references dans le MAILLAGE a sauvegarder.
  276. WRITE(IOIMP,502) 'Construction de la liste des maillages a sauver'
  277. C Rajout de tous les maillages elementaires dans ITAB non deja listes
  278. DO i=1,ITAB(/1)
  279. MELEME=ITAB(i)
  280. SEGACT,MELEME
  281. j=LISOUS(/1)
  282. IF (j.NE.0) THEN
  283. DO k=1,j
  284. IPT1=LISOUS(k)
  285. DO l=1,ITAB(/1)
  286. IF (IPT1.EQ.ITAB(l)) GOTO 3
  287. ENDDO
  288. ITAB(**)=IPT1
  289. 3 CONTINUE
  290. ENDDO
  291. ENDIF
  292. SEGDES,MELEME
  293. ENDDO
  294. C Analyse de tous les maillages elementaires
  295. C + Determination des groupes de noeuds
  296. C= Ne sont conserves que les maillages dont le type correspond
  297. C= a ceux du MAILLAGE a sauver et les maillages de type POI1.
  298. DO i=1,ITAB(/1)
  299. MELEME=ITAB(i)
  300. SEGACT,MELEME
  301. IF (LISOUS(/1).NE.0) GOTO 11
  302. IF (ITYPEL.EQ.1) GOTO 10
  303. DO j=1,IN_EF*NB_EF,IN_EF
  304. IF (MELEME.EQ.MLISEF.LECT(j)) GOTO 11
  305. IF (ITYPEL.EQ.lTypEF(MLISEF.LECT(j+1))) GOTO 10
  306. ENDDO
  307. C*I WRITE(ioimp,*) 'Maillage',i,MELEME,'type EF pas ok',ITYPEL
  308. ITAB(i)=0
  309. GOTO 11
  310. 10 CONTINUE
  311. nbnn=NUM(/1)
  312. nbel=NUM(/2)
  313. DO j=1,nbel
  314. DO k=1,nbnn
  315. IF (NUM(k,j).GT.IMAX) THEN
  316. C*I write(ioimp,*) 'Maillage avec noe > IMAX',i,MELEME
  317. ITAB(i)=0
  318. GOTO 11
  319. ENDIF
  320. ENDDO
  321. ENDDO
  322. IF (ITYPEL.EQ.1) ITAB(i)=-MELEME
  323. 11 CONTINUE
  324. SEGDES,MELEME
  325. ENDDO
  326. C ReAnalyse de tous les maillages complexes
  327. C= Les maillages de POI1 ne sont jamais complexes !
  328. DO i=1,ITAB(/1)
  329. MELEME=ITAB(i)
  330. IF (MELEME.LE.0) GOTO 20
  331. SEGACT,MELEME
  332. j=LISOUS(/1)
  333. IF (j.EQ.0) GOTO 21
  334. DO k=1,j
  335. IPT1=LISOUS(k)
  336. DO l=1,ITAB(/1)
  337. IF (IPT1.EQ.ITAB(l)) GOTO 22
  338. ENDDO
  339. C*I write(ioimp,*) 'Maillage complexe sousref pas OK',i,k,IPT1
  340. ITAB(i)=0
  341. GOTO 21
  342. 22 CONTINUE
  343. ENDDO
  344. 21 CONTINUE
  345. SEGDES,MELEME
  346. 20 CONTINUE
  347. ENDDO
  348. C Liste des objets a considerer pour la sauvegarde (IMAIL)
  349. NBMAIL=0
  350. DO i=1,ITAB(/1)
  351. IF (ITAB(i).NE.0) NBMAIL=NBMAIL+1
  352. ENDDO
  353. C*I WRITE(IOIMP,*) 'NBMAIL=',NBMAIL,ITAB(/1)
  354. SEGINI,IMAIL
  355. j=0
  356. CHA16z='0000000000000000'
  357. DO i=1,ITAB(/1)
  358. k=ITAB(i)
  359. IF (k.NE.0) THEN
  360. j=j+1
  361. I_OBJ(j)=4
  362. IF (k.LT.0) I_OBJ(j)=1
  363. I_MAI(j)=ABS(k)
  364. C_OBJ(j)=' '
  365. DO l=1,NB_EF
  366. m=IN_EF*(l-1)+1
  367. IF (k.EQ.MLISEF.LECT(m)) THEN
  368. I_OBJ(j)=2
  369. L_OBJ(j)=-l
  370. C_OBJ(j)=MCHAEF.LCHA16(l)
  371. CHA16z(l:l)='1'
  372. ENDIF
  373. ENDDO
  374. ENDIF
  375. ENDDO
  376. SEGSUP,ITAB
  377. IF (j.NE.NBMAIL) write(ioimp,*) '=> probleme !'
  378. IF (CHA16z.NE.CODEEF) THEN
  379. WRITE(IOIMP,510) 'codage incorrect'
  380. GOTO 901
  381. ENDIF
  382. C Poursuite de l'analyse des maillages elementaires
  383. C= Verification et remplissage de IMAIL
  384. JMAX=IMAX+1
  385. JG=JMAX
  386. SEGINI,MLENTI
  387. i_z=0
  388. DO i=1,NB_EF
  389. MELEME=MLISEF.LECT(i_z+1)
  390. SEGACT,MELEME
  391. nbnn=NUM(/1)
  392. nbel=NUM(/2)
  393. DO j=1,nbel
  394. DO k=1,nbnn
  395. j_z=NUM(k,j)
  396. LECT(j_z)=LECT(j_z)+1
  397. ENDDO
  398. ENDDO
  399. DO j=2,IMAX
  400. LECT(j)=LECT(j)+LECT(j-1)
  401. ENDDO
  402. JG=LECT(IMAX)
  403. LECT(JMAX)=JG
  404. SEGINI,MLENT1
  405. DO j=1,nbel
  406. DO k=1,nbnn
  407. j_z=NUM(k,j)
  408. k_z=LECT(j_z)
  409. MLENT1.LECT(k_z)=j
  410. LECT(j_z)=LECT(j_z)-1
  411. ENDDO
  412. ENDDO
  413. NumEF=MLISEF.LECT(i_z+3)
  414. DO j=1,NBMAIL
  415. IF (I_OBJ(j).LT.3) GOTO 30
  416. IPT1=I_MAI(j)
  417. IF (IPT1.EQ.MELEME) GOTO 30
  418. SEGACT,IPT1
  419. IF (IPT1.ITYPEL.NE.ITYPEL) GOTO 31
  420. nbnn=IPT1.NUM(/1)
  421. nbel=IPT1.NUM(/2)
  422. JG=nbel
  423. SEGINI,MLENT2
  424. j_z=0
  425. DO iel1=1,nbel
  426. iel=IPT1.NUM(1,iel1)
  427. ideb=LECT(iel)+1
  428. ifin=LECT(iel+1)
  429. IF (ifin.LT.ideb) GOTO 32
  430. DO k=ideb,ifin
  431. iel=MLENT1.LECT(k)
  432. DO l=1,nbnn
  433. IF (NUM(l,iel).NE.IPT1.NUM(l,iel1)) GOTO 34
  434. ENDDO
  435. j_z=j_z+1
  436. MLENT2.LECT(j_z)=NumEF+iel
  437. GOTO 33
  438. 34 CONTINUE
  439. ENDDO
  440. C*I write(ioimp,*) 'elt du maillage pas ds mlisef',j,IPT1,iel1,i
  441. GOTO 32
  442. 33 CONTINUE
  443. ENDDO
  444. 32 CONTINUE
  445. IF (j_z.NE.nbel) THEN
  446. I_OBJ(j)=0
  447. SEGSUP,MLENT2
  448. C*I write(ioimp,*) 'Mail',j,I_OBJ(j),' = non sauve'
  449. ELSE IF (j_z.EQ.NUM(/2)) THEN
  450. I_OBJ(j)=2
  451. L_OBJ(j)=-i
  452. SEGSUP,MLENT2
  453. C*I write(ioimp,*) 'Mail.',j,I_OBJ(j),'=Mail.EF',L_OBJ(j)
  454. ELSE
  455. I_OBJ(j)=3
  456. L_OBJ(j)=MLENT2
  457. SEGDES,MLENT2
  458. C*I write(ioimp,*) 'Mail.',j,I_OBJ(j),'=Mail.elem',L_OBJ(j)
  459. ENDIF
  460. 31 CONTINUE
  461. SEGDES,IPT1
  462. 30 CONTINUE
  463. ENDDO
  464. SEGSUP,MLENT1
  465. SEGDES,MELEME
  466. i_z=i_z+IN_EF
  467. C= Ne pas oublier de remettre a zero MLENTI pour le type EF suivant
  468. IF (NB_EF.NE.1) THEN
  469. DO j=1,JMAX
  470. LECT(j)=0
  471. ENDDO
  472. ENDIF
  473. ENDDO
  474. SEGSUP,MLENTI
  475. C ReAnalyse de tous les maillages complexes
  476. C + Fin du remplissage de IMAIL
  477. DO i=1,NBMAIL
  478. IF (I_OBJ(i).NE.4) GOTO 40
  479. MELEME=I_MAI(i)
  480. SEGACT,MELEME
  481. JG=LISOUS(/1)
  482. IF (JG.EQ.0) THEN
  483. C*I write(ioimp,*) 'Bizarre I_OBJ=4 et LISOUS(/1)=0 pour ITAB',i
  484. GOTO 41
  485. ENDIF
  486. SEGINI,MLENTI
  487. L_OBJ(i)=MLENTI
  488. DO j=1,JG
  489. IPT1=LISOUS(j)
  490. DO k=1,NBMAIL
  491. IF (IPT1.EQ.I_MAI(k)) GOTO 42
  492. ENDDO
  493. C*I write(ioimp,*) 'Maillage complexe sousref pas OK',i,k,IPT1
  494. I_OBJ(i)=0
  495. L_OBJ(i)=0
  496. SEGSUP,MLENTI
  497. GOTO 41
  498. 42 CONTINUE
  499. LECT(j)=k
  500. ENDDO
  501. 41 CONTINUE
  502. C*I write(ioimp,*) 'Mail.complexe',i,I_OBJ(i),L_OBJ(i)
  503. SEGDES,MELEME
  504. 40 CONTINUE
  505. ENDDO
  506. C Recuperation des MAILLAGEs nommes
  507. i_z=0
  508. CALL REPERT('MAILLAGE',i_z)
  509. IF (i_z.GT.0) THEN
  510. CALL REPLIS('MAILLAGE',MLNOMS)
  511. SEGACT,MLNOMS
  512. DO i=1,i_z
  513. CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU)
  514. IF (IERR.NE.0) THEN
  515. SEGSUP,MLNOMS
  516. GOTO 901
  517. ENDIF
  518. DO j=1,NB_EF
  519. IF (IPT1.EQ.MLISEF.LECT(IN_EF*(j-1)+1))
  520. & MCHAEF.LCHA16(j)=LINOMS(i)(1:16)
  521. ENDDO
  522. DO j=1,NBMAIL
  523. IF (IPT1.EQ.I_MAI(j)) C_OBJ(j)=LINOMS(i)(1:16)
  524. ENDDO
  525. ENDDO
  526. SEGSUP,MLNOMS
  527. ENDIF
  528. C Nom par defaut pour les maillages non nommes
  529. j=0
  530. iel=0
  531. DO i=1,NBMAIL
  532. IF (C_OBJ(i)(1:4).EQ.' ') THEN
  533. IF (I_OBJ(i).EQ.1) THEN
  534. j=j+1
  535. C_OBJ(i)(1:4)='Noe_'
  536. WRITE(C_OBJ(i)(5:8),FMT='(I4.4)') j
  537. ELSE IF (I_OBJ(i).GE.3) THEN
  538. iel=iel+1
  539. C_OBJ(i)(1:4)='Elt_'
  540. WRITE(C_OBJ(i)(5:8),FMT='(I4.4)') iel
  541. ENDIF
  542. ENDIF
  543. ENDDO
  544. C Determination du nombre de groupe de noeuds et de groupe d'elements
  545. NB_GNO=0
  546. NB_GEL=0
  547. DO i=1,NBMAIL
  548. IF (I_OBJ(i).EQ.1) THEN
  549. NB_GNO=NB_GNO+1
  550. ELSE IF (I_OBJ(i).EQ.2) THEN
  551. IF (C_OBJ(i).NE.MCHAEF.LCHA16(-L_OBJ(i))) NB_GEL=NB_GEL+1
  552. ELSE IF (I_OBJ(i).EQ.3) THEN
  553. NB_GEL=NB_GEL+1
  554. ELSE IF (I_OBJ(i).EQ.4) THEN
  555. NB_GEL=NB_GEL+1
  556. MLENTI=L_OBJ(i)
  557. k=0
  558. DO j=1,LECT(/1)
  559. j_z=I_OBJ(LECT(j))
  560. IF (j_z.EQ.2.OR.j_z.EQ.3) k=k+1
  561. ENDDO
  562. IF (k.NE.LECT(/1)) THEN
  563. WRITE(IOIMP,510) 'ANORMALE (50)'
  564. GOTO 901
  565. ENDIF
  566. ENDIF
  567. 50 CONTINUE
  568. ENDDO
  569.  
  570. C===
  571. C 3 - Ecriture dans le fichier de sortie au format Abaqus(R)
  572. C===
  573. C Ouverture du fichier au format Abaqus(R)
  574. WRITE(IOIMP,500) 'Ouverture du fichier au format Abaqus(R)'
  575. IOS=1
  576. CLOSE(UNIT=IUABA,ERR=901)
  577. IOS=0
  578. OPEN(UNIT=IUABA,STATUS='UNKNOWN',FILE=FicAba(1:LONG(FicAba)),
  579. & IOSTAT=IOS,FORM='FORMATTED')
  580. IF (IOS.NE.0) GOTO 901
  581. C Ecriture entete (a completer)
  582. WRITE(IOIMP,502) 'Ecriture de l entete du fichier'
  583. WRITE(IUABA,800) '****'
  584. C Ecriture des noeuds du maillage
  585. WRITE(IOIMP,502) 'Ecriture des noeuds du maillage'
  586. WRITE(IUABA,800) '** DEFINITION DES NOEUDS DU MAILLAGE'
  587. WRITE(IUABA,800) '****'
  588. WRITE(IUABA,800) '*NODE, SYSTEM=R'
  589. IF (IDIM.EQ.3) THEN
  590. DO i=1,IMAX
  591. j=idimp1*(i-1)
  592. WRITE(IUABA,FMT=810) i,XCOOR(j+1),XCOOR(j+2),XCOOR(j+3)
  593. ENDDO
  594. ELSE IF (IDIM.EQ.2) THEN
  595. DO i=1,IMAX
  596. j=idimp1*(i-1)
  597. WRITE(IUABA,FMT=811) i,XCOOR(j+1),XCOOR(j+2)
  598. ENDDO
  599. ELSE
  600. DO i=1,IMAX
  601. j=idimp1*(i-1)
  602. WRITE(IUABA,FMT=812) i,XCOOR(j+1)
  603. ENDDO
  604. ENDIF
  605. WRITE(IUABA,800) '****'
  606. WRITE(IOIMP,501) 'Nombre de noeuds =',IMAX
  607. C Ecriture des points nommes (un seul noeud)
  608. C Construction de la table des points nommes existants
  609. WRITE(IOIMP,502) 'Ecriture des points nommes'
  610. I_PTS=0
  611. CALL REPERT('POINT ',I_PTS)
  612. IF (I_PTS.NE.0) THEN
  613. WRITE(IUABA,800) '** DEFINITION DES NOEUDS NOMMES'
  614. WRITE(IUABA,800) '****'
  615. CALL REPLIS('POINT ',MLNOMS)
  616. SEGACT,MLNOMS
  617. DO i=1,I_PTS
  618. CALL LIROBJ('POINT ',IP1,1,IRETOU)
  619. IF (IERR.NE.0) THEN
  620. SEGSUP,MLNOMS
  621. GOTO 902
  622. ENDIF
  623. IF (IP1.GE.1 .AND. IP1.LE.IMAX) THEN
  624. WRITE(IUABA,820) LINOMS(i)(1:LONG(LINOMS(i)))
  625. WRITE(IUABA,821) IP1
  626. ENDIF
  627. ENDDO
  628. SEGSUP,MLNOMS
  629. WRITE(IUABA,800) '****'
  630. ENDIF
  631. WRITE(IOIMP,501) 'Nombre de noeuds nommes =',I_PTS
  632. C Ecriture des groupes de noeuds
  633. C= NSET au sens Abaqus et maillage de type POI1 au sens Cast3m
  634. WRITE(IOIMP,502) 'Ecriture des groupes de noeuds'
  635. IF (NB_GNO.NE.0) THEN
  636. WRITE(IUABA,800) '** DEFINITION DES GROUPES DE NOEUDS'
  637. WRITE(IUABA,800) '****'
  638. DO i=1,NBMAIL
  639. IF (I_OBJ(i).EQ.1) THEN
  640. MELEME=I_MAI(i)
  641. SEGACT,MELEME
  642. WRITE(IUABA,820) C_OBJ(i)(1:LONG(C_OBJ(i)))
  643. WRITE(IUABA,822) (NUM(1,k),k=1,NUM(/2))
  644. SEGDES,MELEME
  645. ENDIF
  646. ENDDO
  647. WRITE(IUABA,800) '****'
  648. ENDIF
  649. WRITE(IOIMP,501) 'Nombre de groupe de noeuds =',NB_GNO
  650. C Ecriture des differents elements
  651. WRITE(IOIMP,502) 'Ecriture des elements du maillage'
  652. WRITE(IUABA,800) '** DEFINITION DES ELEMENTS'
  653. WRITE(IUABA,800) '****'
  654. DO i=1,NB_EF
  655. j=IN_EF*(i-1)
  656. MELEME=MLISEF.LECT(j+1)
  657. i_z =MLISEF.LECT(j+2)
  658. NumEF =MLISEF.LECT(j+3)
  659. CHA16z=MCHAEF.LCHA16(i)
  660. WRITE(IUABA,830) NomAba(i_z)(1:LONG(NomAba(i_z))),
  661. & CHA16z(1:LONG(CHA16z))
  662. C*I WRITE(IOIMP,501) 'Orientation selon Abq ',i
  663. C Orientation des elements du maillage selon Abaqus :
  664. SEGACT,MELEME*MOD
  665. nbnn=NUM(/1)
  666. nbel=NUM(/2)
  667. IELE=ITYPEL
  668. C Recuperation des fonctions de forme et derivees associees de
  669. C l'element fini massif de type IELE
  670. CALL RESHPT(1,nbnn,IELE,IELE,0,ISPT,IRETOU)
  671. IF (IRETOU.NE.1) GOTO 60
  672. MINTE=ISPT
  673. SEGACT,MINTE
  674. nbno=nbnn
  675. SEGINI,MWRK
  676. DO iel=1,nbel
  677. C Recuperation des coordonnees des noeuds de l'element
  678. CALL DOXE(XCOOR,IDIM,nbnn,NUM,iel,XEL)
  679. C Calcul du jacobien au centre de gravite de l'element
  680. D11=0.
  681. D21=0.
  682. D12=0.
  683. D22=0.
  684. IF (IDIM.EQ.3) THEN
  685. D31=0.
  686. D32=0.
  687. D13=0.
  688. D23=0.
  689. D33=0.
  690. DO j=1,nbnn
  691. D11=D11+SHPTOT(2,j,1)*XEL(1,j)
  692. D21=D21+SHPTOT(3,j,1)*XEL(1,j)
  693. D31=D31+SHPTOT(4,j,1)*XEL(1,j)
  694. D12=D12+SHPTOT(2,j,1)*XEL(2,j)
  695. D22=D22+SHPTOT(3,j,1)*XEL(2,j)
  696. D32=D32+SHPTOT(4,j,1)*XEL(2,j)
  697. D13=D13+SHPTOT(2,j,1)*XEL(3,j)
  698. D23=D23+SHPTOT(3,j,1)*XEL(3,j)
  699. D33=D33+SHPTOT(4,j,1)*XEL(3,j)
  700. ENDDO
  701. DInv11=D22*D33-D23*D32
  702. DInv12=D32*D13-D12*D33
  703. DInv13=D12*D23-D22*D13
  704. DJAC=D11*DInv11+D21*DInv12+D31*DInv13
  705. ELSE IF (IDIM.EQ.2) THEN
  706. DO j=1,nbnn
  707. D11=D11+SHPTOT(2,j,1)*XEL(1,j)
  708. D21=D21+SHPTOT(3,j,1)*XEL(1,j)
  709. D12=D12+SHPTOT(2,j,1)*XEL(2,j)
  710. D22=D22+SHPTOT(3,j,1)*XEL(2,j)
  711. ENDDO
  712. DJAC=D11*D22-D21*D12
  713. C* ELSE IF (IDIM.EQ.1) THEN
  714. ELSE
  715. DJAC=XEL(1,nbnn)-XEL(1,1)
  716. ENDIF
  717. C Test si le jacobien est nul (pas bon)
  718. IF (ABS(DJAC).LE.0.) THEN
  719. CALL ERREUR(664)
  720. WRITE(IUABA,801) 'Element incorrect',NumEF+j
  721. ENDIF
  722. C Si le jacobien est negatif, on permute l'ordre des noeuds
  723. IF (DJAC.LT.0.) THEN
  724. DO k=1,nbno
  725. NOEELT(k)=NUM(lInver(k,i_z),iel)
  726. ENDDO
  727. DO k=1,nbno
  728. NUM(k,iel)=NOEELT(k)
  729. ENDDO
  730. ENDIF
  731. ENDDO
  732. SEGSUP,MWRK
  733. SEGDES,MINTE
  734. 60 CONTINUE
  735. IF (IERR.NE.0) THEN
  736. WRITE(IOIMP,510) 'ORIENTATION - Poursuite ecriture'
  737. WRITE(IUABA,800) '!! ERREUR ORIE - Verifier le maillage'
  738. ENDIF
  739. C*I WRITE(IOIMP,501) 'Ecriture des elements type '//NomAba(i_z)
  740. DO k=1,nbel
  741. NumEF=NumEF+1
  742. WRITE(IUABA,831) NumEF,(NUM(lOrdre(l,i_z),k),l=1,nbno)
  743. ENDDO
  744. SEGDES,MELEME
  745. ENDDO
  746. WRITE(IUABA,FMT='(A4)') '****'
  747. WRITE(IOIMP,501) 'Nb. type d elements =',NB_EF
  748. WRITE(IOIMP,501) 'Nombre d elements =',NB_ELT
  749. C Ecriture des groupes d elements
  750. WRITE(IOIMP,502) 'Ecriture des groupes d elements'
  751. IF (NB_GEL.GT.0) THEN
  752. WRITE(IUABA,800) '** DEFINITION DES GROUPES D ELEMENTS'
  753. WRITE(IUABA,800) '****'
  754. C Ecriture des groupes d elements (un seul type)
  755. k=0
  756. DO i=1,NBMAIL
  757. IF (I_OBJ(i).EQ.3) THEN
  758. WRITE(IUABA,840) C_OBJ(i)(1:LONG(C_OBJ(i)))
  759. MLENTI=L_OBJ(i)
  760. SEGACT,MLENTI
  761. WRITE(IUABA,841) (LECT(j),j=1,LECT(/1))
  762. SEGDES,MLENTI
  763. k=k+1
  764. ENDIF
  765. ENDDO
  766. C* write(ioimp,501) 'Nb. groupe d elements un seul EF',k
  767. IF (k.NE.0) WRITE(IUABA,800) '****'
  768. k=0
  769. DO i=1,NBMAIL
  770. IF (I_OBJ(i).EQ.2) THEN
  771. CHA16z=MCHAEF.LCHA16(-L_OBJ(i))
  772. IF (C_OBJ(i).NE.CHA16z) THEN
  773. WRITE(IUABA,840) C_OBJ(i)(1:LONG(C_OBJ(i)))
  774. WRITE(IUABA,800) ' '//CHA16z(1:LONG(CHA16z))
  775. k=k+1
  776. ENDIF
  777. ENDIF
  778. ENDDO
  779. C* write(ioimp,501) 'Nb. groupe d elements def elt =',k
  780. IF (k.NE.0) WRITE(IUABA,800) '****'
  781. C Ecriture des groupes d elements complexes
  782. k=0
  783. DO i=1,NBMAIL
  784. IF (I_OBJ(i).EQ.4) THEN
  785. WRITE(IUABA,840) C_OBJ(i)(1:LONG(C_OBJ(i)))
  786. MLENTI=L_OBJ(i)
  787. WRITE(IUABA,842) (C_OBJ(LECT(j))(1:LONG(C_OBJ(LECT(j)))),
  788. & j=1,LECT(/1))
  789. k=k+1
  790. ENDIF
  791. ENDDO
  792. C* write(ioimp,501) 'Nb. groupe d elements complexe =',k
  793. IF (k.NE.0) WRITE(IUABA,800) '****'
  794. ENDIF
  795. WRITE(IOIMP,501) 'Nombre de groupe d elements =',NB_GEL
  796.  
  797. C===
  798. C 4 - Sortie du sous-programme (menage...)
  799. C===
  800. 902 CONTINUE
  801. WRITE(IOIMP,502) 'Fermeture du fichier au format Abaqus(R)'
  802. IOS=1
  803. CLOSE(UNIT=IUABA,ERR=901)
  804. IOS=0
  805. 901 CONTINUE
  806. DO i=1,NBMAIL
  807. MELEME=I_MAI(i)
  808. IF (MELEME.GT.0) SEGDES,MELEME
  809. MLENTI=L_OBJ(i)
  810. IF (MLENTI.GT.0) SEGSUP,MLENTI
  811. ENDDO
  812. SEGSUP,IMAIL
  813. 900 CONTINUE
  814. MELEME=MAIREF
  815. SEGACT,MELEME
  816. IF (NB_OBJ.NE.0) THEN
  817. DO i=1,NB_OBJ
  818. IPT1=LISOUS(i)
  819. SEGDES,IPT1
  820. ENDDO
  821. ENDIF
  822. SEGDES,MELEME
  823. SEGSUP,MLISEF,MCHAEF
  824. C Traitement des erreurs d ouverture ou de fermeture du fichier
  825. IF (IOS.NE.0) THEN
  826. l=LONG(FicAba)
  827. MOTERR(1:l)=FicAba(1:l)
  828. INTERR(1)=IOS
  829. CALL ERREUR(424)
  830. ENDIF
  831. WRITE(IOIMP,*)
  832.  
  833. C=====
  834. C 5 - Formats Fortran
  835. C=====
  836. C Formats d impression de messages
  837. 500 FORMAT('SORABA : ',A)
  838. 501 FORMAT(' ',A,I8)
  839. 502 FORMAT(' ',A)
  840. 510 FORMAT('SORABA - ERREUR : ',A)
  841. C* 511 FORMAT('SORABA - ERREUR : ',A,' ',I4,' non defini')
  842. C* 512 FORMAT('SORABA - ERREUR : ',A,' ',I4,' mal defini')
  843. C* 513 FORMAT('SORABA - ERREUR : Lecture impossible ',A,' ',I4)
  844. C* 520 FORMAT('SORABA - ATTENTION : ',A)
  845. C* 521 FORMAT('SORABA - ATTENTION : ',A,' ',I4,' non defini')
  846. C* 522 FORMAT('SORABA - ATTENTION : ',A,' ',I4,' mal defini')
  847. C* 523 FORMAT('SORABA - ATTENTION : ',A,' ',A,' ',I4)
  848. C Formats d ecriture pour le fichier de sortie Abaqus(R)
  849. 800 FORMAT(A)
  850. 801 FORMAT(A,' ',I8)
  851. 810 FORMAT(I8,', ',SP,E14.8,', ',E14.8,', ',E14.8,S)
  852. 811 FORMAT(I8,', ',SP,E14.8,', ',E14.8,S)
  853. 812 FORMAT(I8,', ',SP,E14.8,S)
  854. 820 FORMAT('*NSET, NSET=',A)
  855. 821 FORMAT(I8)
  856. 822 FORMAT(10(I8,','))
  857. 830 FORMAT('*ELEMENT, TYPE=',A,', ELSET=',A)
  858. 831 FORMAT(I8,', ',19(I8,','),I8)
  859. 840 FORMAT('*ELSET, ELSET=',A)
  860. 841 FORMAT(16(I8,','))
  861. 842 FORMAT(1X,16(A10,','))
  862.  
  863. RETURN
  864. END
  865.  
  866.  
  867.  
  868.  
  869.  
  870.  

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