Télécharger optnum.eso

Retour à la liste

Numérotation des lignes :

  1. C OPTNUM SOURCE PV 15/09/08 21:15:01 8594
  2. SUBROUTINE OPTNUM(MELEME,MEMJT1,memjt2,JMEM,JNT,NEWJT,JOINT,
  3. > IDIFF,IPOME,ICPR,NODES,NOOPTI)
  4. *
  5. * renumérotation des noeuds en vue de la résolution
  6. * par la méthode de Cuthill Mac Kee inversée
  7. *
  8. *
  9. IMPLICIT INTEGER(I-N)
  10. -INC SMELEME
  11. -INC CCOPTIO
  12. SEGMENT MEMJT1(0)
  13. SEGMENT MEMJT2(0)
  14. SEGMENT IPOME(0)
  15. SEGMENT JNT (0)
  16. SEGMENT JMEM (0)
  17. SEGMENT NEWJT(0)
  18. SEGMENT JOINT(0)
  19. SEGMENT ICPR (0)
  20. C SEGMENT OU STOCKE LES ELEMENTS DEJA ESSAYES
  21. SEGMENT IDJFC(IDJFCL)
  22. SEGMENT IDJF(IDJFL)
  23. C SEGMENT OU STOCKER LES POINTS DE DEPARTS DEJA ESSAYES
  24. SEGMENT NPES(NODES)
  25. CHARACTER*4 MVAL(1)
  26. INTEGER IPASG
  27. SAVE IPASG
  28. DATA IPASG/0/
  29. DATA MVAL/'NOOP'/
  30. lasur0=0
  31. cout0=0.d0
  32. NOOPTI=0
  33. IPT1=MELEME
  34. CALL LIRMOT(MVAL,1,IRET,0)
  35. IF (IRET.EQ.0) GOTO 2
  36. NOOPTI=1
  37. DO 4 J=1,NODES
  38. JNT(J)=J
  39. 4 CONTINUE
  40. RETURN
  41. 2 CONTINUE
  42. nvoisl=16
  43. if (nucrou.eq.1) nvoisl=64
  44. SEGINI NPES
  45. DO 5 I=1,NODES
  46. NPES(I)=0
  47. 5 CONTINUE
  48. IDJFCL=MAX(1,LISOUS(/1))
  49. SEGINI IDJFC
  50. IPT1=MELEME
  51. DO 6 ISOUS=1,IDJFCL
  52. IF (LISOUS(/1).NE.0) IPT1=LISOUS(ISOUS)
  53. IDJFL=IPT1.NUM(/2)
  54. SEGINI IDJF
  55. IDJFC(ISOUS)=IDJF
  56. 6 CONTINUE
  57. MINMAX=500000
  58. ICON=1
  59. ITER=1
  60. IBOUT=1
  61. IK=1
  62. NK5=1
  63. 1 CONTINUE
  64. NPES(IK)=1
  65. DO 230 IO=1,MAX(1,LISOUS(/1))
  66. IF(LISOUS(/1).NE.0) IPT1=LISOUS(IO)
  67. IF(IPT1.ITYPEL.NE.22) GO TO 230
  68. DO 240 LA=1,IPT1.NUM(/2)
  69. NPES(ICPR(IPT1.NUM(1,LA)))=1
  70. NPES(ICPR(IPT1.NUM(2,LA)))=1
  71. 240 CONTINUE
  72. 230 CONTINUE
  73. DO 20 J=1,NODES
  74. JOINT(J)=0
  75. 20 NEWJT(J)=0
  76. LASURT=0
  77. MUX=0
  78. I=1
  79. NEWJT(1)=IK
  80. JOINT(IK)=1
  81. K=1
  82. 30 IND=NEWJT(I)
  83. IND1=IND
  84. K4=JMEM(IND)
  85. JSUB=IPOME(NEWJT(I))
  86. * tentative tc
  87. DO 40 JJ=k4,1,-1
  88. ** DO 40 JJ=1,k4
  89. IND=JSUB+JJ
  90. IAIA= memjt2(ind)
  91. K6=memjt1(ind)
  92. IDJF=IDJFC(MAX(1,IAIA))
  93. IF (IDJF(K6).EQ.1) GOTO 40
  94. IF(LISOUS(/1).NE.0) IPT1=LISOUS(IAIA)
  95. IPOSL2=0
  96. ** DO 85 L=1,IPT1.NUM(/1)
  97. DO 85 LT=1,IPT1.NUM(/1)
  98. l=lt
  99. IF(IPT1.ITYPEL.EQ.22) then
  100. l=lt+1
  101. if (lt.eq.1) l=1
  102. if (lt.eq.ipt1.num(/1)) l=2
  103. endif
  104. K5=ICPR(IPT1.NUM(l,K6))
  105. IF (JOINT(K5).GT.0) GO TO 85
  106. if (npes(k5).eq.0) nk5=k5
  107. K=K+1
  108. NEWJT(K)=K5
  109. JOINT(K5)=K
  110. NDIFF=ABS(I-K)
  111. MUX=MAX(MUX,NDIFF)
  112. IF(IPT1.ITYPEL.EQ.22.AND.IPT1.NUM(/1).NE.0) GO TO 86
  113. GOTO 85
  114. 86 CONTINUE
  115. * on insere le multiplicateur 1 avant i (deja atteint)
  116. * on insere le second apres le noeud le plus haut de l'element (type 22
  117. * on mettra celui-ci apres tous les autres
  118. IF (L.EQ.1) THEN
  119. DO 87 M=K,I+1,-1
  120. NEWJT(M)=NEWJT(M-1)
  121. JOINT(NEWJT(M))=M
  122. 87 CONTINUE
  123. NEWJT(I)=K5
  124. JOINT(K5)=I
  125. I=I+1
  126. ELSEIF (L.EQ.2) THEN
  127. IPOSL2=K
  128. ENDIF
  129. 85 CONTINUE
  130. IDJF(K6)=1
  131.  
  132. IF (IPT1.ITYPEL.EQ.22.AND.IPOSL2.NE.0) THEN
  133. * on s'occupe maintenant du 2eme multiplicateur de lagrange
  134. IHAUT=0
  135. DO 89 L=3,IPT1.NUM(/1)
  136. K3=ICPR(IPT1.NUM(L,K6))
  137. IHAUT=MAX(IHAUT,JOINT(K3))
  138. 89 CONTINUE
  139. NEWSAU=NEWJT(IPOSL2)
  140. IF(IHAUT+1.EQ.IPOSL2) GO TO 40
  141. IF (IHAUT.LT.IPOSL2) THEN
  142. DO 88 M=IPOSL2,IHAUT+2,-1
  143. NEWJT(M)=NEWJT(M-1)
  144. JOINT(NEWJT(M))=M
  145. 88 CONTINUE
  146. NEWJT(IHAUT+1)=NEWSAU
  147. JOINT(NEWSAU)=IHAUT+1
  148. ELSE
  149. DO 84 M=IPOSL2,IHAUT-1
  150. NEWJT(M)=NEWJT(M+1)
  151. JOINT(NEWJT(M))=M
  152. 84 CONTINUE
  153. NEWJT(IHAUT)=NEWSAU
  154. JOINT(NEWSAU)=IHAUT
  155. ENDIF
  156. ENDIF
  157. 40 CONTINUE
  158. IF(K.EQ.NODES) GO TO 50
  159. I=I+1
  160. IF (I.NE.K+1) GO TO 30
  161. K=K+1
  162. DO 23 L=1,NODES
  163. IF (JOINT(L).EQ.0) GO TO 24
  164. 23 CONTINUE
  165. CALL ERREUR(9)
  166. 24 CONTINUE
  167. NEWJT(K)=L
  168. JOINT(L)=K
  169. IBOUT=IBOUT+1
  170. GO TO 30
  171. 50 CONTINUE
  172. * 60 CONTINUE
  173. II=IK
  174. INTERR(1)=IBOUT
  175. IF(ITER.EQ.1.AND.IBOUT.NE.1.AND.IPASG.EQ.0) THEN
  176. IF(LOCERR(1:4).EQ.'RESO') CALL ERREUR(754)
  177. IPASG = 1
  178. ENDIF
  179. LASURT=0
  180. LASURF=0
  181. DO 46 IB=1,NODES
  182. LONG=IB
  183. LANG=IB
  184. IC=NEWJT(IB)
  185. K4=JMEM(IC)
  186. JSUB=IPOME(IC)
  187. DO 43 JJB=1,K4
  188. IND=JSUB+JJB
  189. IAIA= memjt2(ind)
  190. IF(LISOUS(/1).NE.0) IPT1=LISOUS(IAIA)
  191. K6=memjt1(ind)
  192. DO 44 IKL=1,IPT1.NUM(/1)
  193. JKL=JOINT(ICPR(IPT1.NUM(IKL,K6)))
  194. LONG=MAX(LONG,JKL)
  195. LANG=MIN(LANG,JKL)
  196. 44 CONTINUE
  197. 43 CONTINUE
  198. LASURT=LASURT+LONG-IB
  199. LASURF=LASURF+IB-LANG
  200. 46 CONTINUE
  201. ** IF (MINMAX.LE.MUX) GOTO 60
  202. ** if (lasur0.ne.0.and.lasurt.gt.lasur0) goto 60
  203. cout=5.d0*log(real(mux+1))+log(real(lasurt+1))+log(real(lasurf+1))
  204. if (cout0.ne.0.d0.and.cout.ge.cout0) goto 60
  205. cout0=cout
  206.  
  207. MINMAX=MIN(MINMAX,MUX)
  208. lasur0=lasurt
  209. IF(IIMPI.EQ.3)
  210. 1WRITE (IOIMP,62) ITER,IK,MUX,LASURF,LASURT
  211. 62 FORMAT(' ITERATION:',I3,' DEPART:',I8,' BANDE:',I6,' SURFACE: ',
  212. #I13,' SURF INV:',I13)
  213. DO 55 J=1,NODES
  214. 55 JNT(J)=JOINT(J)
  215. ICON=0
  216. NVOIS=0
  217. 60 CONTINUE
  218. IK=NK5
  219. DO 95 IO=1,IDJFC(/1)
  220. IDJF=IDJFC(IO)
  221. DO 97 LA=1,IDJF(/1)
  222. 97 IDJF(LA)=0
  223. 95 CONTINUE
  224. ICON=ICON+1
  225. ITER=ITER+1
  226. IF (ICON.LE.3.AND.NPES(IK).EQ.0) GOTO 1
  227. IF (NVOIS.GT.0) GO TO 101
  228. LH=0
  229. nvois=0
  230. 101 continue
  231. do i=1,nodes
  232. newjt(jnt(i))=i
  233. enddo
  234. 102 continue
  235. lh=lh+1
  236. if (lh.gt.nodes) goto 71
  237. if (nvois.gt.nvoisl) goto 71
  238. ik=newjt(lh)
  239. if (nvois.ge.128) ik=newjt(nodes+129-lh)
  240. if (npes(ik).eq.1) goto 102
  241. nvois=nvois+1
  242. goto 1
  243. 71 CONTINUE
  244. IDIFF=MINMAX
  245. DO 105 J=1,IDJFC(/1)
  246. IDJF=IDJFC(J)
  247. SEGSUP IDJF
  248. 105 CONTINUE
  249. SEGSUP IDJFC
  250. SEGSUP NPES
  251. RETURN
  252. END
  253.  
  254.  
  255.  
  256.  
  257.  
  258.  
  259.  
  260.  

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