Télécharger redfor.eso

Retour à la liste

Numérotation des lignes :

  1. C REDFOR SOURCE BP208322 15/06/22 21:21:35 8543
  2. * élimination des ddls supprimés dans le second membre réduit
  3. subroutine redfor(mchpoi,ri4,mchpo1)
  4. * inspiré de transr et mschp1 (MASQ)
  5. * mchpoi : entree = second membre réduit avec ddls supprimés
  6. * ri4 : entree = matrice de relation
  7. * mchpo1 : sortie = second membre réduit sans ddls supprimés
  8. IMPLICIT INTEGER(I-N)
  9. IMPLICIT REAL*8 (A-H,O-Z)
  10. -INC SMCHPOI
  11. -INC SMRIGID
  12. -INC CCOPTIO
  13. -INC CCHAMP
  14. -INC SMCOORD
  15. -INC SMELEME
  16. -INC TMTRAV
  17. *
  18. SEGMENT/MTRA/(NOPOIN(XCOOR(/1)/(IDIM+1)))
  19. SEGMENT MTR1
  20. CHARACTER*4 IPCOM(0)
  21. ENDSEGMENT
  22. SEGMENT/MTR4/(IPHAR(0))
  23. CHARACTER*4 nomp,nomd
  24. *
  25. SEGINI MTRA,MTR1,MTR4
  26. *
  27. * Initialisation de MTRAV, MTRA, MTR1, MTR4 (repris de mschp1.eso)
  28. *
  29. SEGACT MCHPOI
  30. IK=0
  31. NSOUPO=IPCHP(/1)
  32. DO 20 IA=1,NSOUPO
  33. MSOUPO=IPCHP(IA)
  34. SEGACT MSOUPO
  35. MELEME=IGEOC
  36. SEGACT MELEME
  37. NBELEM=NUM(/2)
  38. DO 30 IB=1,NBELEM
  39. K=NUM(1,IB)
  40. IF(NOPOIN(K).NE.0) GO TO 30
  41. IK=IK+1
  42. NOPOIN(K)=IK
  43. 30 CONTINUE
  44. SEGDES MELEME
  45. NCBBB=NOCOMP(/2)
  46. DO 40 IB=1,NCBBB
  47. NC=IPCOM(/2)
  48. DO 50 IC=1,NC
  49. IF(IPCOM(IC).NE.NOCOMP(IB)) GO TO 50
  50. IF(IPHAR(IC).EQ.NOHARM(IB)) GO TO 40
  51. 50 CONTINUE
  52. IPCOM(**)=NOCOMP(IB)
  53. IPHAR(**)=NOHARM(IB)
  54. 40 CONTINUE
  55. SEGDES MSOUPO
  56. 20 CONTINUE
  57. C
  58. NNIN=IPCOM(/2)
  59. NNNOE=IK
  60. SEGINI MTRAV
  61. DO 70 IA=1,NNIN
  62. INCO(IA)=IPCOM(IA)
  63. NHAR(IA)=IPHAR(IA)
  64. 70 CONTINUE
  65. C
  66. C CREATION DE BB,IBIN,IGEO
  67. C
  68. NSOUPO=IPCHP(/1)
  69. DO 80 IA=1,NSOUPO
  70. MSOUPO=IPCHP(IA)
  71. SEGACT MSOUPO
  72. MELEME=IGEOC
  73. MPOVAL=IPOVAL
  74. SEGACT MELEME,MPOVAL
  75. NBELEM=NUM(/2)
  76. NC=VPOCHA(/2)
  77. NC1=NOCOMP(/2)
  78. C
  79. DO 90 IB=1,NC1
  80. DO 100 IC=1,NNIN
  81. IF(NOCOMP(IB).NE.IPCOM(IC)) GO TO 100
  82. IF(NOHARM(IB).EQ.IPHAR(IC)) GO TO 110
  83. 100 CONTINUE
  84. * Pas de composante trouvée, ce n'est pas normal
  85. goto 9999
  86. 110 CONTINUE
  87. DO 120 ID=1,NBELEM
  88. KI=NOPOIN(NUM(1,ID))
  89. IGEO(KI)=NUM(1,ID)
  90. IBIN(IC,KI)=1
  91. BB(IC,KI)=VPOCHA(ID,IB)
  92. 120 CONTINUE
  93. 90 CONTINUE
  94. SEGDES MELEME,MPOVAL
  95. SEGDES MSOUPO
  96. 80 CONTINUE
  97. SEGDES MCHPOI
  98. * on balaye les raideurs de dependances, on supprime les ddl dependants
  99. * dans le MTRAV
  100. segact ri4
  101. do 1100 irig=1,ri4.irigel(/2)
  102. if (ri4.irigel(8,irig).ne.0) then
  103. descr=ri4.irigel(3,irig)
  104. meleme=ri4.irigel(1,irig)
  105. Xmatri=ri4.irigel(4,irig)
  106. segact descr,meleme,xmatri
  107. do 1110 iligrp=1,lisinc(/2)
  108. if (lisinc(iligrp).eq.'LX ') goto 1120
  109. 1110 continue
  110. goto 1100
  111. 1120 continue
  112. * Le multiplicateur de lagrange n'est pas en première position
  113. * dans le descripteur de la matrice, ce n'est pas prévu
  114. if (iligrp.ne.1) goto 9999
  115. nbelem=num(/2)
  116. * on supprime le multiplicateur de lagrange et le ddl dépendant
  117. do idep=1,2
  118. nomp=lisinc(idep)
  119. * on trouve le nom dual correspondant (si non trouvé dual=primal)
  120. nomd=nomp
  121. do ipri=1,lnomdd
  122. if (nomp.eq.nomdd(ipri)) nomd=nomdu(ipri)
  123. enddo
  124. iharm=ri4.irigel(5,irig)
  125. inin=0
  126. do ii=1,nhar(/1)
  127. if (inco(ii).eq.nomd.and.nhar(ii).eq.iharm) inin=ii
  128. enddo
  129. if (inin.ne.0) then
  130. do 1130 i=1,nbelem
  131. * write(ioimp,*) 'ddl a eliminer ',iharm,nomd,' ',
  132. * $ num(noelep(idep),i)
  133. ik=nopoin(num(noelep(idep),i))
  134. if (ik.ne.0) ibin(inin,ik)=0
  135. 1130 continue
  136. endif
  137. enddo
  138. segdes descr,meleme,xmatri
  139. endif
  140. 1100 continue
  141. segdes ri4
  142. segsup MTRA,MTR1,MTR4
  143. *
  144. * On reconstruit le chpoint nettoyé et on lui donne les mêmes
  145. * caractéristiques que l'original
  146. *
  147. CALL CRECHP(mtrav,mchpo1)
  148. segsup mtrav
  149. segact mchpo1*mod
  150. segact mchpoi
  151. mchpo1.mochde='créé par redfor'
  152. mchpo1.ifopoi=ifopoi
  153. do i=1,min(mchpo1.jattri(/1),jattri(/1))
  154. mchpo1.jattri(i)=jattri(i)
  155. enddo
  156. segdes mchpoi
  157. segdes mchpo1
  158. return
  159.  
  160. 9999 continue
  161. MOTERR(1:8)='REDFOR '
  162. CALL ERREUR(1039)
  163. RETURN
  164. end
  165.  
  166.  
  167.  
  168.  
  169.  
  170.  
  171.  
  172.  
  173.  
  174.  

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