Télécharger prdall.eso

Retour à la liste

Numérotation des lignes :

  1. C PRDALL SOURCE BP208322 16/11/18 21:20:05 9177
  2. C PRDALL SOURCE CHAT 06/03/29 21:29:12 5360
  3. C MODIF : O.STAB / 29.10.96 / DALLAG EST REMPLACE PAR DALLOS QUI
  4. C AUTORISE UN NOMBRE DE NOEUDS DIFFERENTS SUR LES COTES EN VIS-A-VIS
  5. C CE SOUS-PROGRAMME INTERFACE DALLAG IL LIT LES DONNEES ET RAMENE
  6. C EN COORDONNEES LOCALES
  7. C
  8. SUBROUTINE PRDALL
  9. IMPLICIT INTEGER(I-N)
  10. IMPLICIT REAL*8 (A-H,O-Z)
  11. -INC CCOPTIO
  12. -INC CCGEOME
  13. -INC SMELEME
  14. -INC SMCOORD
  15. C PIFFARD . RENAULT : AJOUT DES SEGMENTS IC1 A IC4
  16. * SEGMENT IC1(50)
  17. * SEGMENT IC2(50)
  18. * SEGMENT IC3(50)
  19. * SEGMENT IC4(50)
  20. * DIMENSION NELD1(2),NELA1(2),NELD2(2),NELA2(2),NELD3(2),NELA3(2)
  21. * DIMENSION NELD4(2),NELA4(2)
  22. C
  23. REAL*8 TCVAL(13)
  24. SEGMENT /FER/(NFI(ITT),MAI(IPP),ITOUR)
  25. SEGMENT XPROJ(3,IMAX)
  26. SEGMENT /SAUV/(NSA(MAI(ITOUR+1)))
  27. PARAMETER (LCAS = 7)
  28. c ITEST(0:NBCOUL-1)
  29. DIMENSION ITEST(0:30)
  30. CHARACTER*4 MCAS(LCAS)
  31. CHARACTER*4 DALL
  32. PARAMETER (DALL = 'DALL')
  33. INTEGER NKCOIN(4),NBN(4)
  34. DATA MCAS/'PLAN','SPHE','CYLI','CONI','TORI','QUEL','POLY'/
  35. isens=0
  36. mpsurf=0
  37. *
  38. IF (KSURF(ILCOUR).EQ.0) THEN
  39. CALL ERREUR(16)
  40. RETURN
  41. END IF
  42. CALL LIRMOT(MCAS,LCAS,ICAS,0)
  43. IF (ICAS.EQ.0.AND.IDIM.EQ.2) ICAS=1
  44. IF (IDIM.EQ.2.AND.(ICAS.GE.2.AND.ICAS.LE.5)) THEN
  45. MOTERR(1:4)=MCAS(ICAS)
  46. CALL ERREUR(7)
  47. RETURN
  48. ENDIF
  49. *
  50. IF (ICAS.EQ.0) ICAS=6
  51. *
  52. IF (ICAS .LE. 6) THEN
  53. CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU)
  54. CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU)
  55. CALL LIROBJ('MAILLAGE',IPT3,1,IRETOU)
  56. CALL LIROBJ('MAILLAGE',IPT4,1,IRETOU)
  57. IF (ICAS.NE.6) THEN
  58. IF (ICAS.GT.1) CALL LIROBJ('POINT ',IP1,1,IRETOU)
  59. IF (ICAS.GT.2) CALL LIROBJ('POINT ',IP2,1,IRETOU)
  60. IF (ICAS.EQ.5) CALL LIROBJ('POINT ',IP3,1,IRETOU)
  61. ENDIF
  62. ELSE
  63. * ICAS = 7 :
  64. CALL SURFP1 (DALL,IPT1,IPT2,IPT3,IPT4,IBID,msurfp)
  65. END IF
  66. IF (IERR.NE.0) RETURN
  67. NC = 4
  68. *
  69. SEGACT IPT1,IPT2,IPT3,IPT4
  70. IF (IPT1.ITYPEL.NE.IPT2.ITYPEL) CALL ERREUR(16)
  71. IF (IPT1.ITYPEL.NE.IPT3.ITYPEL) CALL ERREUR(16)
  72. IF (IPT1.ITYPEL.NE.IPT4.ITYPEL) CALL ERREUR(16)
  73. IF (IERR.NE.0) GOTO 1000
  74. C ==================================
  75. C ------- DEBUT DE MODIF - O.STAB 25.03.97 --------
  76. C ==================================
  77. IF((IDIM.LE.1).OR.(IDIM.GT.3))THEN
  78. C WRITE (6,*) 'L OPERATEUR NE FONCTIONNE QU EN 2D OU 3D'
  79. CALL ERREUR(832)
  80. ENDIF
  81. C
  82. C --- TEST DES CARDINAUX ---
  83. C
  84. NBN(1) = IPT1.NUM(/2)
  85. NBN(2) = IPT2.NUM(/2)
  86. NBN(3) = IPT3.NUM(/2)
  87. NBN(4) = IPT4.NUM(/2)
  88. C
  89. DO 10 I=1,4
  90. C WRITE (6,*) 'UN COTE N A PAS D ELEMENTS'
  91. IF(NBN(I).LE.0)CALL ERREUR(830)
  92. 10 CONTINUE
  93. C
  94. C
  95. IF(MOD(NBN(1)+NBN(2)+NBN(3)+NBN(4),2).NE.0)THEN
  96. C WRITE(6,*) 'LE NOMBRE TOTAL D ELEMENTS EST IMPAIR'
  97. CALL ERREUR(831)
  98. ENDIF
  99. C
  100. CALL G2NBKK(NBN(1),NBN(2),NBN(3),NBN(4),
  101. > NKCOIN(1),NKCOIN(2),NKCOIN(3),NKCOIN(4),IERRDS)
  102. C
  103. NBLIG = MAX(NBN(4)+NKCOIN(4)+NKCOIN(3),
  104. > NBN(2)+NKCOIN(2)+NKCOIN(1)) + 1
  105. NBCOL = MAX(NKCOIN(4)+NBN(1)+NKCOIN(1),
  106. > NKCOIN(2)+NBN(3)+NKCOIN(3)) + 1
  107. C
  108. C WRITE(6,*)'NBLIG,NBCOL = ',NBLIG,NBCOL
  109. C WRITE(6,*)'NBN = ',(NBN(I),I=1,4)
  110. C WRITE(6,*)'NKCOIN = ',(NKCOIN(I),I=1,4)
  111. C
  112. C MNOMB=IPT1.NUM(/2)
  113. C IF (MNOMB.NE.IPT3.NUM(/2)) CALL ERREUR(33)
  114. C NNOMB=IPT2.NUM(/2)
  115. C IF (NNOMB.NE.IPT4.NUM(/2)) CALL ERREUR(33)
  116. C ================================
  117. C ------- FIN DE MODIF - O.STAB 25.03.97 --------
  118. C ================================
  119. C MNOMB=IPT1.NUM(/2)
  120. C IF (MNOMB.NE.IPT3.NUM(/2)) CALL ERREUR(33)
  121. C NNOMB=IPT2.NUM(/2)
  122. C IF (NNOMB.NE.IPT4.NUM(/2)) CALL ERREUR(33)
  123. IF (IERRDS.NE.0) THEN
  124. call erreur(26)
  125. GOTO 1000
  126. ENDIF
  127. do 15 i=0,NBCOUL-1
  128. itest(i)=0
  129. 15 continue
  130. DO 20 I=1,IPT1.NUM(/2)
  131. ITEST(IPT1.ICOLOR(I))=1
  132. 20 CONTINUE
  133. DO 25 I=1,IPT2.NUM(/2)
  134. ITEST(IPT2.ICOLOR(I))=1
  135. 25 CONTINUE
  136. DO 30 I=1,IPT3.NUM(/2)
  137. ITEST(IPT3.ICOLOR(I))=1
  138. 30 CONTINUE
  139. DO 35 I=1,IPT4.NUM(/2)
  140. ITEST(IPT4.ICOLOR(I))=1
  141. 35 CONTINUE
  142. ICHCOL=-1
  143. DO 40 I=0,NBCOUL-1
  144. IF (ITEST(I).EQ.1) THEN
  145. IF (ICHCOL.EQ.-1) THEN
  146. ICHCOL=I
  147. ELSE
  148. ICHCOL=ITABM(ICHCOL,I)
  149. ENDIF
  150. ENDIF
  151. 40 CONTINUE
  152. NBNN=IPT1.NUM(/1)
  153. C ==================================
  154. C ------- DEBUT DE MODIF - O.STAB 25.03.97 --------
  155. C ==================================
  156. C NBELEM=2*MNOMB+2*NNOMB
  157. NBELEM= NBN(1)+NBN(2)+NBN(3)+NBN(4)
  158. NBREF=0
  159. NBSOUS=0
  160. SEGINI IPT5
  161. IPT5.ITYPEL=IPT1.ITYPEL
  162. C
  163. C ON ASSEMBLE LES QUATRES COTES EN UN CONTOUR FERME
  164. C
  165. DO 100 I=1,NBNN
  166. DO 101 J=1,NBN(1)
  167. IPT5.NUM(I,J)=IPT1.NUM(I,J)
  168. 101 CONTINUE
  169. DO 102 J=1,NBN(2)
  170. IPT5.NUM(I,J+NBN(1))=IPT2.NUM(I,J)
  171. 102 CONTINUE
  172. DO 103 J=1,NBN(3)
  173. IPT5.NUM(I,J+NBN(1)+NBN(2))=IPT3.NUM(I,J)
  174. 103 CONTINUE
  175. DO 104 J=1,NBN(4)
  176. IPT5.NUM(I,J+NBN(1)+NBN(2)+NBN(3))=IPT4.NUM(I,J)
  177. 104 CONTINUE
  178. 100 CONTINUE
  179. SEGDES IPT1,IPT2,IPT3,IPT4
  180. IPT6=1
  181. C
  182. C --- CONSTRUCTION DU POLYGONE DANS FER ---
  183. CALL AVTRSF(IPT5,FER,IPT6)
  184. IF (IERR.NE.0) GOTO 1001
  185. SEGSUP IPT5
  186. SEGINI SAUV
  187. DO 60 I=1,NSA(/1)
  188. 60 NSA(I)=NFI(I)
  189. C
  190. IF(ICAS.EQ.1)CALL PPLAN(1,FER,XPROJ,NDEB,NUMNP,tcval)
  191. IF(ICAS.EQ.2)CALL PSPHE(1,FER,XPROJ,NDEB,NUMNP,IP1,tcval)
  192. IF(ICAS.EQ.3)CALL PCYLI(1,FER,XPROJ,NDEB,NUMNP,IP1,IP2,
  193. $ tcval,isens)
  194. IF(ICAS.EQ.4)CALL PCONE(1,FER,XPROJ,NDEB,NUMNP,IP1,IP2,
  195. $ tcval,isens)
  196. IF(ICAS.EQ.5)CALL PTORI(1,FER,XPROJ,NDEB,NUMNP,IP1,IP2,IP3,tcval,
  197. $ isens)
  198. IF(ICAS.EQ.6)CALL PQUEL(1,FER,XPROJ,NDEB,NUMNP)
  199. IF(ICAS.EQ.7)CALL SURFP5 (FER,XPROJ,NDEB,msurfp)
  200. IF(IERR.NE.0) RETURN
  201. C
  202. C
  203. C
  204. MNOMB = NBN(1)
  205. NNOMB = NBN(2)
  206. C CALL DALLAG(MNOMB,NNOMB,FER,XPROJ,MELEME,NUMELG,NUMNP)
  207. C
  208. C REMPLACE PAR :
  209. C
  210. C write(6,*) 'MELEME =',MELEME
  211. CALL DALLOS(NBN,FER,XPROJ,NBLIG,NBCOL,NKCOIN,
  212. > MELEME,NUMELG,NUMNP,IERRDS)
  213. C write(6,*) 'MELEME =',MELEME
  214. C
  215. C
  216. IF( IERRDS.NE. 0 ) THEN
  217. CALL ERREUR(26)
  218. RETURN
  219. ENDIF
  220. C WRITE(6,*) 'ERREUR DANS DALLOS ',IERRDS
  221. C GOTO 9999
  222. C ENDIF
  223. C
  224. C write(6,*) 'LE MAILLAGE EN SORTIE DE DALLOS'
  225. C write(6,*) 'NBE,NBN =',NUMELG,NUMNP
  226. C WRITE(6,*) ((MELEME.NUM(J,I),J=1,4),I=1,NUMELG)
  227. C WRITE(6,*) ((XPROJ(J,I),J=1,XPROJ(/1)),I=1,NUMNP)
  228. C
  229. C ==================================
  230. C ------- FIN DE MODIF - O.STAB 25.03.97 --------
  231. C ==================================
  232.  
  233. ITY=KSURF(ILCOUR)
  234. ITYPEL=8
  235. CALL CHANGS(NUMNP,NUMELG,ITY,MELEME,XPROJ,IPT6)
  236. ID1=XCOOR(/1)/(IDIM+1)
  237. IF(ICAS.EQ.1)CALL PPLAN(2,FER,XPROJ,NDEB,NUMNP,tcval)
  238. IF(ICAS.EQ.2)CALL PSPHE(2,FER,XPROJ,NDEB,NUMNP,IP1,tcval)
  239. IF(ICAS.EQ.3)CALL PCYLI(2,FER,XPROJ,NDEB,NUMNP,IP1,IP2,
  240. $ tcval,isens)
  241. IF(ICAS.EQ.4)CALL PCONE(2,FER,XPROJ,NDEB,NUMNP,IP1,IP2,
  242. $ tcval,isens)
  243. IF(ICAS.EQ.5)CALL PTORI(2,FER,XPROJ,NDEB,NUMNP,IP1,IP2,IP3,tcval,
  244. $ isens)
  245. IF(ICAS.EQ.6)CALL PQUEL(2,FER,XPROJ,NDEB,NUMNP)
  246. *>>>>> P.M. 04/10/90
  247. IF (ICAS.EQ.7) CALL SURFP6 (DALL,XPROJ,NDEB,NUMNP,1,msurfp)
  248. *<<<<<
  249. SEGSUP,FER
  250. *
  251. NBNN=NUM(/1)
  252. NBREF=4
  253. NBSOUS=0
  254. NBELEM=NUMELG
  255. SEGINI IPT5
  256. IPT5.LISREF(1)=IPT1
  257. IPT5.LISREF(2)=IPT2
  258. IPT5.LISREF(3)=IPT3
  259. IPT5.LISREF(4)=IPT4
  260. IPT5.ITYPEL=KSURF(ILCOUR)
  261. IDEC=ID1-NDEB+1
  262. DO 50 I=1,NBNN
  263. DO 50 J=1,NBELEM
  264. IANC=NUM(I,J)
  265. IF (IANC.GE.NDEB) GOTO 61
  266. IPT5.NUM(I,J)=NSA(IANC)
  267. GOTO 50
  268. 61 IPT5.NUM(I,J)=IANC+IDEC
  269. 50 CONTINUE
  270. DO 45 I=1,IPT5.NUM(/2)
  271. 45 IPT5.ICOLOR(I)=ICHCOL
  272. SEGSUP SAUV,MELEME
  273. SEGDES IPT5
  274. CALL ECROBJ('MAILLAGE',IPT5)
  275. SEGDES IPT5
  276. 1000 SEGDES IPT1,IPT2
  277. IF (NC.GT.2) SEGDES IPT3
  278. IF (NC.GT.3) SEGDES IPT4
  279. RETURN
  280. 1001 SEGSUP IPT5
  281. RETURN
  282. END
  283.  
  284.  
  285.  
  286.  
  287.  
  288.  
  289.  
  290.  
  291.  
  292.  
  293.  

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