Télécharger resou1.eso

Retour à la liste

Numérotation des lignes :

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

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