Télécharger resou1.eso

Retour à la liste

Numérotation des lignes :

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

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