Télécharger la plaquette Cast3M


fr en

Télécharger excham.eso

Retour à la liste

Numérotation des lignes : 

excham

  1. C EXCHAM    SOURCE    OF166741  24/10/03    21:15:09     12022          
  2.       SUBROUTINE EXCHAM(ICOLAC,ITLACC,M1,M2,IIICHA)
  3.       IMPLICIT INTEGER(I-N)
  4.       IMPLICIT REAL*8(A-H,O-Z)
  5. *--------------------------------------------------------------------*
  6. *                                                                    *
  7. *     Sous-programme appel{ par EXPIL, traitant la pile des          *
  8. *     nouveaux CHAMELEMs.                                            *
  9. *                                                                    *
  10. *     Param}tres:                                                    *
  11. *                                                                    *
  12. * e   ICOLAC  pointeur sur le chapeau des piles                      *
  13. * es  ITLACC  pointeur de la pile examin{e                           *
  14. * e   M1      premier indice d'examen dans la pile                   *
  15. * e   M2      dernier indice d'examen dans la pile                   *
  16. * e   IIICHA  = 1 : on change les pointeurs                          *
  17. *                                                                    *
  18. *--------------------------------------------------------------------*
  19. -INC PPARAM
  20. -INC CCOPTIO
  21. -INC SMCHAML
  22. -INC TMCOLAC
  23.  
  24.       CHARACTER*8  MOTIP
  25.       CHARACTER*16 MOTYP
  26.  
  27.       IF (M1.GT.M2) RETURN
  28.  
  29.       iun=1
  30.       ICO1 = KCOLA( 1)
  31.       ILISSE=ILISSG
  32.       SEGACT ILISSE*MOD
  33.       DO 10 IEL=M1,M2
  34.          MCHELM = ITLAC(IEL)
  35.          IF (MCHELM.EQ.0) GO TO 10
  36.          SEGACT,MCHELM*MOD
  37.          if (ichaml(/1).lt.0.or.ichaml(/1).gt.10000000) then
  38. *  chelm  invalide. On le supprime de la pile
  39.           moterr(1:8)='MCHELM  '
  40.           interr(1)=itlac(iel)
  41.           call erreur(861)
  42.           itlac(iel)=0
  43.           goto 10
  44.          endif
  45.          DO 20 I=1,ICHAML(/1)
  46.             MCHAML = ICHAML(I)
  47.             SEGACT,MCHAML*MOD
  48.  
  49.             IVA  = IMACHE(I)
  50.             IF(IVA.GT.0) THEN
  51.             CALL AJOUN(ICO1,IVA,ILISSE,iun)
  52.             IF (IIICHA.EQ.1) IMACHE(I) =-IVA
  53.             ENDIF
  54.  
  55.             IVA  = INFCHE(I,4)
  56.             IF (IVA.GT.0) THEN
  57.             ICO2 = KCOLA(40)
  58.             CALL AJOUN(ICO2,IVA,ILISSE,iun)
  59.             IF (IIICHA.EQ.1) INFCHE(I,4) =-IVA
  60.             ENDIF
  61.  
  62.             DO 30 J=1,TYPCHE(/2)
  63.                MOTYP = TYPCHE(J)
  64.                IF (MOTYP(1:6).NE.'REAL*8') THEN
  65.                   MOTIP(1:8)=MOTYP(9:16)
  66.                   CALL TYPFIL(MOTIP,ITYP)
  67.                   IF (ITYP.GT.0) THEN
  68.                      NUMLIS=1
  69.                      ilissd=ilissg
  70.                      IF(ITYP.EQ.24) NUMLIS=6
  71. C                     IF(ITYP.EQ.25) NUMLIS=4
  72.                      IF(ITYP.EQ.26) NUMLIS=2
  73.                      IF(ITYP.EQ.27) NUMLIS=5
  74.                      IF(ITYP.EQ.32) then
  75.                       NUMLIS=3
  76.                       ILISSD=ilissp
  77.                      ENDIF
  78.                      IF(ITYP.EQ.36) NUMLIS=7
  79.                      ICO2 = KCOLA(ITYP)
  80.                      MELVAL = IELVAL(J)
  81.                       SEGACT,MELVAL*MOD
  82.                       NAL1 = IELCHE(/1)
  83.                       NAL2 = IELCHE(/2)
  84.                       DO 40 I2=1,NAL2
  85.                         DO 50 I1=1,NAL1
  86.                            IVA = IELCHE(I1,I2)
  87.                            IF(IVA.GT.0) THEN
  88.                            CALL AJOUN(ICO2,IVA,ILISSD,NUMLIS)
  89.                            IF (IIICHA.EQ.1) IELCHE(I1,I2) =-IVA
  90.                            ENDIF
  91.  50                        CONTINUE
  92. *                       END DO
  93.  40                     CONTINUE
  94. *                    END DO
  95.                       SEGDES,MELVAL
  96.  
  97.                   ENDIF
  98.                ELSE
  99. *  segment de reel. Il a sa propre pile, IELVAL
  100.                      if (ionive.ge.20) then
  101.                        IVA=IELVAL(J)  
  102.                        ICO2=KCOLA(48)
  103. **                     write (6,*) ' ajout de ',iva,' dans ',ico2
  104.                        IF (IVA.GT.0) THEN
  105.                          CALL AJOUN(ICO2,IVA,ILISSE,iun)
  106.                          IF (IIICHA.EQ.1) IELVAL(J)=-IVA
  107.                        ENDIF
  108.                      endif
  109.                ENDIF
  110.  30            CONTINUE
  111. *           END DO
  112.             SEGDES,MCHAML
  113.  20         CONTINUE
  114. *        END DO
  115.          SEGDES,MCHELM
  116.  10      CONTINUE
  117. *     END DO
  118.  
  119. *      SEGDES ILISSE
  120.       RETURN
  121.       END
  122.  
  123.  
  124.  

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