Télécharger la plaquette Cast3M


fr en

Télécharger ldmt.eso

Retour à la liste

Numérotation des lignes : 

ldmt

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

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