Télécharger prlimi.eso

Retour à la liste

Numérotation des lignes :

  1. C PRLIMI SOURCE AF221230 13/08/01 21:15:10 7808
  2. C PRLIMI SOURCE
  3. SUBROUTINE PRLIMI(CALDYN,IG,ITAB,IFIC1,IRIG,NMOD,IMAI,NNO,IFIC2)
  4. C
  5. C=======================================================================
  6. C POUR MISS3D : ECRITURE DES MODES SUR FICHIER .chp
  7. C ET DU MAILLAGE SUR FICHIER .mail
  8. C
  9. C Appelle par l'operateur MISE
  10. C=======================================================================
  11. C
  12. IMPLICIT INTEGER(I-N)
  13. IMPLICIT REAL*8(A-H,O-Z)
  14. LOGICAL CALDYN
  15. -INC SMTABLE
  16. -INC SMCOORD
  17. -INC CCOPTIO
  18. -INC SMELEME
  19. -INC SMCHPOI
  20. C
  21. CHARACTER*8 ITYPE
  22. CHARACTER*72 LEMOT
  23. PARAMETER (ZERO=0.D0)
  24. INTEGER ICMP(3)
  25. INTEGER KN(8)
  26. DATA KN /0,0,0,0,0,0,0,0/
  27. C
  28. IF(CALDYN)THEN
  29. C
  30. C Ecriture pour les vrais modes
  31. WRITE(IFIC1,*)'GROUP 2'
  32. WRITE(IFIC1,*)'MODE',NMOD
  33. DO 20 I=1,NMOD
  34. WRITE(IFIC1,*)'TOUS 0 0 0'
  35. WRITE(IFIC1,*)'FIN'
  36. 20 CONTINUE
  37. C
  38. C Ecriture des modes statiques
  39. WRITE(IFIC1,*)'GROUP 1 2'
  40. MTABLE=ABS(ITAB)
  41. SEGACT MTABLE
  42. NB=MLOTAB
  43. WRITE(IFIC1,*)'MODE',NB-1
  44.  
  45. IF(IRIG.EQ.1)THEN
  46. C
  47. C Fondation souple, on n'ecrit que le DDL concerne pour chaque mode
  48. NBP=(NB-1)/3
  49.  
  50. DO 10 IJ=1,NB
  51. ITYPE=MTABTI(IJ)
  52. IF(ITYPE.EQ.'ENTIER')THEN
  53. IRET=MTABII(IJ)
  54. MTAB1=MTABIV(IJ)
  55. CALL ACCTAB(MTAB1,'MOT',0,0.0D0,'POINT_LIAISON',.TRUE.,0,
  56. & 'POINT',IP,RR,LEMOT,.TRUE.,IPOIN)
  57. CALL ACCTAB(MTAB1,'MOT',0,0.0D0,'DDL_LIAISON',.TRUE.,0,
  58. & 'MOT',IP,RR,LEMOT,.TRUE.,IZ)
  59. CALL ACCTAB(MTAB1,'MOT',0,0.0D0,'VALEUR_DDL',.TRUE.,0,
  60. & 'FLOTTANT',IP,VAL,LEMOT,.TRUE.,IZ)
  61. IF (VAL.EQ.00013081984) THEN
  62. CALL ACCTAB(MTAB1,'MOT',0,0.0D0,'DEFORMEE',.TRUE.,0,
  63. & 'CHPOINT',IP,RR,LEMOT,.TRUE.,JCHP1)
  64. MCHPOI=JCHP1
  65. SEGACT MCHPOI
  66. NSOU=IPCHP(/1)
  67. DO 71 ISOU=1,NSOU
  68. MSOUPO=IPCHP(ISOU)
  69. SEGACT MSOUPO
  70. IF(NOCOMP(1).EQ.'LX ')THEN
  71. SEGDES MSOUPO
  72. GOTO 71
  73. ENDIF
  74. IPT1=IGEOC
  75. SEGACT IPT1
  76. NBP=IPT1.NUM(/2)
  77. MPOVAL=IPOVAL
  78. SEGACT MPOVAL
  79. C
  80. C On ordonne les composantes UX, UY et UZ car bizarrement c'est pas toujours dans l'ordre !
  81. NBCOMP=VPOCHA(/2)
  82. DO ICOMP=1,NBCOMP
  83. IF(NOCOMP(ICOMP).EQ.'UX ')THEN
  84. ICMP(1)=ICOMP
  85. ELSEIF(NOCOMP(ICOMP).EQ.'UY ')THEN
  86. ICMP(2)=ICOMP
  87. ELSEIF(NOCOMP(ICOMP).EQ.'UZ ')THEN
  88. ICMP(3)=ICOMP
  89. ENDIF
  90. ENDDO
  91. DO 72 IN=1,NBP
  92. IPOIN=IPT1.NUM(1,IN)
  93. WRITE(IFIC1,110)IPOIN,(VPOCHA(IN,ICMP(IC)),IC=1,3)
  94. 72 CONTINUE
  95. SEGDES MPOVAL
  96. SEGDES MSOUPO
  97. SEGDES IPT1
  98. 71 CONTINUE
  99. WRITE(IFIC1,*)'FIN'
  100. SEGDES MCHPOI
  101. ELSE
  102. C
  103. IF(LEMOT(1:2).EQ.'UX')THEN
  104. WRITE(IFIC1,110)IPOIN,VAL,ZERO,ZERO
  105. ELSEIF(LEMOT(1:2).EQ.'UY')THEN
  106. WRITE(IFIC1,110)IPOIN,ZERO,VAL,ZERO
  107. ELSE
  108. WRITE(IFIC1,110)IPOIN,ZERO,ZERO,VAL
  109. ENDIF
  110. 110 FORMAT(I7,3(1X,E15.6))
  111. WRITE(IFIC1,*)'FIN'
  112. ENDIF
  113. ENDIF
  114. 10 CONTINUE
  115. ELSE
  116. C
  117. C Fondation rigide, on ecrit tous les ddl pour chaque mode
  118. DO 60 IJ=1,NB
  119. ITYPE=MTABTI(IJ)
  120. IF(ITYPE.EQ.'ENTIER')THEN
  121. IRET=MTABII(IJ)
  122. MTAB1=MTABIV(IJ)
  123. CALL ACCTAB(MTAB1,'MOT',0,0.0D0,'DEFORMEE',.TRUE.,0,
  124. & 'CHPOINT',IP,RR,LEMOT,.TRUE.,JCHP1)
  125. MCHPOI=JCHP1
  126. SEGACT MCHPOI
  127. NSOU=IPCHP(/1)
  128. DO 61 ISOU=1,NSOU
  129. MSOUPO=IPCHP(ISOU)
  130. SEGACT MSOUPO
  131. IF(NOCOMP(1).EQ.'LX ')THEN
  132. SEGDES MSOUPO
  133. GOTO 61
  134. ENDIF
  135. IPT1=IGEOC
  136. SEGACT IPT1
  137. NBP=IPT1.NUM(/2)
  138. MPOVAL=IPOVAL
  139. SEGACT MPOVAL
  140. C
  141. C On ordonne les composantes UX, UY et UZ car bizarrement c'est pas toujours dans l'ordre !
  142. NBCOMP=VPOCHA(/2)
  143. DO ICOMP=1,NBCOMP
  144. IF(NOCOMP(ICOMP).EQ.'UX ')THEN
  145. ICMP(1)=ICOMP
  146. ELSEIF(NOCOMP(ICOMP).EQ.'UY ')THEN
  147. ICMP(2)=ICOMP
  148. ELSEIF(NOCOMP(ICOMP).EQ.'UZ ')THEN
  149. ICMP(3)=ICOMP
  150. ENDIF
  151. ENDDO
  152. DO 62 IN=1,NBP
  153. IPOIN=IPT1.NUM(1,IN)
  154. WRITE(IFIC1,110)IPOIN,(VPOCHA(IN,ICMP(IC)),IC=1,3)
  155. 62 CONTINUE
  156. SEGDES MPOVAL
  157. SEGDES MSOUPO
  158. SEGDES IPT1
  159. 61 CONTINUE
  160. WRITE(IFIC1,*)'FIN'
  161. SEGDES MCHPOI
  162. ENDIF
  163. 60 CONTINUE
  164. ENDIF
  165. SEGDES MTABLE
  166. ELSE
  167. ID=(IDIM+1)*(IG-1)
  168. WRITE(IFIC1,*)'GROUP 1'
  169. WRITE(IFIC1,*)'RIGIDE',XCOOR(ID+1),XCOOR(ID+2),XCOOR(ID+3)
  170. ENDIF
  171. C
  172. C Ecriture maillage
  173. MELEME=IMAI
  174. SEGACT MELEME
  175. NBEL=NUM(/2)
  176. NBSOUS=LISOUS(/1)
  177. IF(NBSOUS.NE.0)STOP 'Plusieurs sous maillages'
  178. C
  179. C coordonnees
  180. NNOT=XCOOR(/1)/4
  181. C WRITE(IFIC2,310)NNOT,NBEL
  182. WRITE(IFIC2,310)NNO,NBEL
  183. 310 FORMAT('Maillage interface',/,I5,I5,/,'LIBRE')
  184. C DO 40 IP=1,NNOT
  185. DO 40 IP=1,NNO
  186. WRITE(IFIC2,320)(XCOOR((IP-1)*4+K),K=1,3)
  187. 320 FORMAT(3(1X,E15.6))
  188. 40 CONTINUE
  189. C
  190. C connectivite maillage interface
  191. cccc???? SEGACT MCOORD
  192. C
  193. NBN=NUM(/1)
  194. DO 50 IE=1,NBEL
  195. IF(NBN.EQ.4)THEN
  196. KN(1)=NUM(1,IE)
  197. KN(3)=NUM(2,IE)
  198. KN(5)=NUM(3,IE)
  199. KN(7)=NUM(4,IE)
  200. ELSEIF(NBN.EQ.3)THEN
  201. KN(1)=NUM(1,IE)
  202. KN(3)=NUM(2,IE)
  203. KN(5)=NUM(3,IE)
  204. ELSE
  205. WRITE(IOIMP,*) 'Nombre de noeuds par element : ',NBN
  206. STOP 'pas encore fait dans prlimi.eso'
  207. ENDIF
  208. WRITE(IFIC2,330)(KN(K),K=1,8)
  209. 330 FORMAT(8I7,' GR 1')
  210. C
  211. 50 CONTINUE
  212. C
  213. SEGDES MELEME
  214. C
  215. RETURN
  216. END
  217.  
  218.  

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