Télécharger ldmt.eso

Retour à la liste

Numérotation des lignes :

  1. C LDMT SOURCE PV 16/11/17 22:00:31 9180
  2. SUBROUTINE LDMT(KRIGI,IDAMEM,NOID,NOEN,PREC)
  3. C
  4. C **** SUBROUTINE QUI EXECUTE L OPERATION RESOU
  5. C SUR DES MATRICES SANS SYMETRIES
  6. C **** APPELEE PAR RESOU OU PAR SUPRI
  7. C
  8. C Elle est équivalente à RESOU1 dans le cas de l'inversion des
  9. C matrices symétriques
  10. C
  11. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  12. C
  13. C Auteur : Michel BULIK
  14. C
  15. C Date : Printemps '95
  16. C
  17. C Langage : ESOPE + FORTRAN77
  18. C
  19. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  20. IMPLICIT INTEGER(I-N)
  21. REAL*8 XKT,PREC
  22. INTEGER OOOVAL
  23. SEGMENT IDEMEM(0)
  24. -INC SMRIGID
  25. -INC SMVECTD
  26. -INC CCOPTIO
  27. -INC SMMATRI
  28. C
  29. MRIGID=KRIGI
  30. SEGACT MRIGID
  31. ICHOLX=ICHOLE
  32. SEGDES MRIGID
  33. IF(ICHOLX.NE.0) then
  34. MMATRI=ICHOLX
  35. SEGACT MMATRI
  36. IF (PRCHLV.lt.PREC*1.001.and.PRCHLV.gt.PREC*0.999) GO TO 1
  37. write (6,*) ' attention changement de precision '
  38. MILIGN=IILIGN
  39. segact milign
  40. DO 20 I=1,ILIGN(/1)
  41. LIGN=ILIGN(I)
  42. SEGSUP LIGN
  43. SEGSUP LIGN
  44. 20 CONTINUE
  45. MDIAG=IDIAG
  46. SEGSUP MDIAG
  47. MDNOR=IDNORM
  48. SEGSUP MDNOR
  49. SEGSUP MMATRI
  50. ICHOLX=0
  51. ENDIF
  52. CALL LDMT1(KRIGI,PREC)
  53. IF(IERR.NE.0) GO TO 5000
  54. MRIGID=KRIGI
  55. SEGACT MRIGID
  56. ICHOLX=ICHOLE
  57. SEGDES MRIGID
  58. C
  59. C **** SUBROUTINE CHV2 : TRANSFORME LE CHPOIN ISECO EN VECTEUR
  60. C
  61. 1 CONTINUE
  62. IDEMEM=IDAMEM
  63. SEGACT IDEMEM*MOD
  64. NNTOT=IDEMEM(/1)
  65. MMATRI=ICHOLX
  66. SEGACT MMATRI
  67. MILIGN=IILIGN
  68. SEGACT,MILIGN
  69. INK=IPNO(/1)
  70. SEGDES MILIGN,MMATRI
  71. CALL INTPDO(LENB)
  72. NNPA= MAX(1,((OOOVAL(1,1)-NGMAXY)/(2*LENB))/INK+1)
  73. C
  74. C ON TRAVAILLE AVEC AUTANT DE VECTEUR SIMULTANEE QU'IL EN RENTRE DANS
  75. C LA MOITIE DE LA MEMOIRE CENTRALE
  76. C
  77. NN=NNPA
  78. DO 201 KGEN = 1,NNTOT,NNPA
  79. IF(KGEN+NNPA-1.GT.NNTOT) NN= NNTOT-KGEN+1
  80. KGEN1=KGEN-1
  81. DO 2 K=1,NN
  82. ISECO=IDEMEM(K+KGEN1)
  83. CALL CHVNS(ICHOLX,ISECO,MVECTX,NOID)
  84. IF(IERR.NE.0) GO TO 5000
  85. IDEMEM(K+KGEN1)=MVECTX
  86. 2 CONTINUE
  87. IF(NN.NE.1) THEN
  88. INC = INK * NN
  89. SEGINI MVECTD
  90. DO 3 LL=1,NN
  91. LD=INK*(LL-1)
  92. MVECT1=IDEMEM(LL+KGEN1)
  93. SEGACT MVECT1
  94. DO 4 L=1,INK
  95. 4 VECTBB(L+LD)=MVECT1.VECTBB(L)
  96. SEGSUP MVECT1
  97. 3 CONTINUE
  98. MVECTX=MVECTD
  99. SEGDES MVECTD
  100. ENDIF
  101. C
  102. C **** SUBROUTINE MONDES :
  103. C
  104. IF(IIMPI.EQ.1) THEN
  105. WRITE(IOIMP,499)
  106. 499 FORMAT(' TEMPS SUIVANT AVANT APPEL MONDES')
  107. CALL GIBTEM(XKT)
  108. INTERR(1)=XKT
  109. CALL ERREUR(-259)
  110. ENDIF
  111. CALL MONDES(ICHOLX,MVECTX,NOEN)
  112. IF(IIMPI.EQ.1) THEN
  113. WRITE(IOIMP,498)
  114. 498 FORMAT(' TEMPS SUIVANT APRES APPEL MONDES')
  115. CALL GIBTEM(XKT)
  116. INTERR(1)=XKT
  117. CALL ERREUR(-259)
  118. ENDIF
  119. IF(IERR.NE.0) GO TO 5000
  120. C
  121. C **** SUBROUTINE VCH1 : REMET LE VECTEUR SOUS FORME D UN CHPOINT
  122. C **** LE CHPOINT EST DE TYPE PREMIER MEMBRE
  123. C
  124. MVECTA=MVECTX
  125. DO 5 K=1,NN
  126. IF(NN.EQ.1) GO TO 10
  127. IF(K.EQ.1) THEN
  128. INC=INK
  129. MVECT1=MVECTX
  130. SEGACT MVECT1
  131. SEGINI MVECTD
  132. ENDIF
  133. SEGACT MVECTD*mod
  134. LD=(K-1)*INK
  135. DO 6 L=1,INK
  136. VECTBB(L)=MVECT1.VECTBB(L+LD)
  137. 6 CONTINUE
  138. MVECTA=MVECTD
  139. SEGDES MVECTD
  140. IF(K.EQ.NN) SEGSUP MVECT1
  141. 10 CONTINUE
  142. CALL VCH1(ICHOLX,MVECTA,ISOLU,KRIGI)
  143. IF(IERR.NE.0) RETURN
  144. C
  145. IDEMEM(K+KGEN1)=ISOLU
  146. 5 CONTINUE
  147. MVECTD=MVECTA
  148. SEGSUP MVECTD
  149. 201 CONTINUE
  150. IDAMEM = IDEMEM
  151. SEGDES IDEMEM
  152. C
  153. 5000 CONTINUE
  154. RETURN
  155. END
  156.  
  157.  
  158.  
  159.  
  160.  
  161.  
  162.  
  163.  
  164.  
  165.  
  166.  
  167.  
  168.  
  169.  
  170.  
  171.  
  172.  
  173.  
  174.  
  175.  
  176.  

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