Télécharger la plaquette Cast3M


fr en

Télécharger manuc8.eso

Retour à la liste

Numérotation des lignes : 

manuc8

  1. C MANUC8    SOURCE    CB215821  20/11/04    21:18:52     10766          
  2.       SUBROUTINE MANUC8
  3.       IMPLICIT INTEGER(I-N)
  4.       IMPLICIT REAL*8(A-H,O-Z)
  5. -INC CCGEOME
  6.  
  7. -INC PPARAM
  8. -INC CCOPTIO
  9. -INC SMCHAML
  10. -INC SMLREEL
  11. -INC SMEVOLL
  12. -INC SMTABLE
  13. * attention la dimension de infos doit etre suppereiur a
  14. * deuxieme dimension  de infche
  15.       dimension infos(20)
  16.       SEGMENT IDONN
  17.          REAL*8 XABS(NDI)
  18.          INTEGER IPC(NDI)
  19.       ENDSEGMENT
  20.       SEGMENT ITAFF
  21.          INTEGER JTAFF(NNSO,NNCH)
  22.       ENDSEGMENT
  23.       CHARACTER*72 MOT
  24.       CHARACTER*16 CONCH1,CONCH2
  25.       CHARACTER*(LOCHAI)  NCOPO
  26.       CHARACTER*(LOCOMP)  NOMCH1
  27. *
  28. *     LECTURE DES DONNEES
  29. *
  30.       CALL LIRCHA(NCOPO,1,ILO)
  31.       IF(IERR.NE.0) RETURN
  32. *
  33. *   LECTURE EVENTUELLE D'UNE TABLE et traitement
  34. *
  35.       CALL LIROBJ('TABLE   ',MTABLE,0,IRETOU)
  36.       IF(IRETOU.NE.0) THEN
  37.         SEGACT MTABLE
  38.         NDI = MLOTAB
  39.         SEGINI IDONN
  40.         NVR=0
  41.         DO 7003 I=1,MLOTAB
  42.         IF(MTABTI(I).NE.'ENTIER  '.AND.MTABTI(I).NE.'FLOTTANT')
  43.      $   GO TO 7003
  44.         IF(MTABTV(I).NE.'MCHAML  ') GO TO 7003
  45.         NVR=NVR+1
  46.         IF(MTABTI(I).EQ.'ENTIER  ') THEN
  47.           XABS(NVR)=MTABII(I)
  48.         ELSE
  49.          XABS(NVR)= RMTABI(I)
  50.         ENDIF
  51.         IPC(NVR)=MTABIV(I)
  52.  7003   CONTINUE
  53.         NDI=NVR
  54.         IF(NDI.NE.MLOTAB) SEGADJ IDONN
  55.       ELSE
  56. *
  57. *   LECTURE DES COUPLES  ( FLOT MCHAML)
  58. *
  59.         NVR=0
  60.         NDI=20
  61.         SEGINI IDONN
  62.  7001   CONTINUE
  63.         CALL LIRREE(XVAL,0,IRETOU)
  64.         IF( IRETOU.EQ.0) GO TO 7002
  65.         CALL LIROBJ('MCHAML  ',IPCH,1,IRETOU)
  66.         IF(IERR.NE.0) RETURN
  67.         NVR=NVR+1
  68.         IF(NVR.GT.NDI) THEN
  69.           NDI = NDI +20
  70.           SEGADJ IDONN
  71.         ENDIF
  72.         XABS(NVR)=XVAL
  73.         IPC(NVR)=IPCH
  74.         GO TO 7001
  75.  7002   CONTINUE
  76.         NDI=NVR
  77.         IF(NDI.NE.IPC(/1))SEGADJ IDONN
  78.       ENDIF
  79. *
  80. * fabrication du listreel
  81. *
  82.       JG = NDI
  83.       SEGINI MLREEL
  84.       DO 7020 I=1,NDI
  85.       PROG(I)=XABS(I)
  86.  7020 CONTINUE
  87.       MLABS=MLREEL
  88.       SEGDES MLREEL
  89.  
  90. * on connait la liste XABS (I), IPC(I) quelques verification
  91. *
  92.       MCHEL1=IPC(1)
  93.       SEGACT MCHEL1
  94.       if( mchel1.infche(/2).gt.20) then
  95.         write(6,*) 'MANUC8 :probleme de dimension tableau infos '
  96.         call erreur (5)
  97.         return
  98.       endif
  99.       DO 7009 IK=1,MCHEL1.ICHAML(/1)
  100.       MCHAML=MCHEL1.ICHAML(IK)
  101.       SEGACT MCHAML
  102.       IF(IELVAL(/1).NE.1) THEN
  103.         CALL ERREUR (21)
  104.       ENDIF
  105.  7009 CONTINUE
  106.       NOMCH1=NOMCHE(1)
  107.       DO 7100 I=2,IPC(/1)
  108.       MCHEL2=IPC(I)
  109.       SEGACT MCHEL2
  110.       if( mchel2.infche(/2).gt.20) then
  111.         write(6,*) 'MANUC8 :probleme de dimension tableau infos '
  112.         call erreur (5)
  113.         return
  114.       endif
  115.       IF(MCHEL1.IFOCHE.NE.MCHEL2.IFOCHE)  THEN
  116. *
  117. *     ERREUR IMPOSSIBLE D Avoir DES CHPS/ELMTS
  118. *     DE SS TYPE DIFFERENTS
  119. *
  120.         MOTERR(1:16)=MCHEL1.TITCHE(1:8)//MCHEL2.TITCHE(1:8)
  121.         CALL ERREUR(99)
  122.         RETURN
  123.       ENDIF
  124.       DO 7004 IK=1,MCHEL2.ICHAML(/1)
  125.       MCHAML=MCHEL2.ICHAML(IK)
  126.       SEGACT MCHAML
  127.       IF(IELVAL(/1).NE.1) THEN
  128.         CALL ERREUR (21)
  129.       ENDIF
  130.       IF(NOMCHE(1).NE.NOMCH1) THEN
  131.         CALL ERREUR (21)
  132.       ENDIF
  133.  7004 CONTINUE
  134.  7100 CONTINUE
  135.       MOT=MCHEL1.TITCHE
  136.       L1=MCHEL1.TITCHE(/1)
  137.       N3=MCHEL1.INFCHE(/2)
  138.       NSOUS1=MCHEL1.ICHAML(/1)
  139. *
  140. * QUELLES BIJECTIONS ENTRE LES SOUS PAQUETS  SI OUI TRAITEMENT AMELIORE
  141. *
  142.       NNCH=IPC(/1)
  143.       NNSO=NSOUS1
  144.       SEGINI ITAFF
  145.       DO 7005 IKK=2,NNCH
  146.       MCHEL2=IPC(IKK)
  147.       IF( MCHEL2.ICHAML(/1).NE.NSOUS1) THEN
  148.        CALL ERREUR(19)
  149.        RETURN
  150.       ENDIF
  151.  7005 CONTINUE
  152.       DO 17 ISOUS1=1,NSOUS1
  153.          IPMAI1 = MCHEL1.IMACHE(ISOUS1)
  154.          CONCH1  = MCHEL1.CONCHE(ISOUS1)
  155.          MCHAML=MCHEL1.ICHAML(ISOUS1)
  156.          JTAFF(ISOUS1,1)=IELVAL(1)
  157.          DO 7006 IK=2,IPC(/1)
  158.          MCHEL2=IPC(IK)
  159.          DO 18 ISOUS2=1,NSOUS1
  160.             ISOUS=ISOUS2
  161.             IPMAI2= MCHEL2.IMACHE(ISOUS)
  162.             CONCH2= MCHEL2.CONCHE(ISOUS)
  163.             IF(IPMAI1.EQ.IPMAI2.AND.CONCH1.EQ.CONCH2) THEN
  164. *
  165. *              VERIFICATION POUR LES INFCHE
  166. *
  167.                CALL IDENT (IPMAI1,CONCH1,mchel1,mchel2,INFOS,IRTD)
  168.                IF (IRTD.EQ.0) GOTO 18
  169.                IMINT1=0
  170.                IMINT2=0
  171.               IF (MCHEL1.INFCHE(/2).GE.4) IMINT1=MCHEL1.INFCHE(ISOUS1,4)
  172.               IF (MCHEL2.INFCHE(/2).GE.4) IMINT2=MCHEL2.INFCHE(ISOUS2,4)
  173.               IF (IMINT1.EQ.IMINT2) GOTO 171
  174.                IMINT1=1
  175.                IMINT2=1
  176.               IF (MCHEL1.INFCHE(/2).GE.6) IMINT1=MCHEL1.INFCHE(ISOUS1,6)
  177.               IF (MCHEL2.INFCHE(/2).GE.6) IMINT2=MCHEL2.INFCHE(ISOUS2,6)
  178.                IF (IMINT1.EQ.0) IMINT1=1
  179.                IF (IMINT2.EQ.0) IMINT2=1
  180.                IF (IMINT1.EQ.IMINT2) GOTO 171
  181. *
  182. *              ERREUR IMPOSSIBLE D Avoir DES CHPS/ELMTS
  183. *              DE SS TYPE DIFFERENTS
  184. *
  185.                MOTERR(1:8)=MCHEL1.TITCHE
  186.                MOTERR(9:16)=MCHEL2.TITCHE
  187.                CALL ERREUR(329)
  188.                SEGDES MCHEL1,MCHEL2
  189.                SEGSUP ITAFF
  190.                RETURN
  191.             ENDIF
  192.   18     CONTINUE
  193.          SEGSUP ITAFF
  194.          CALL ERREUR(19)
  195.          RETURN
  196. *
  197.   171    CONTINUE
  198.          MCHAML= MCHEL2.ICHAML(ISOUS)
  199.          JTAFF(ISOUS1,IK)=IELVAL(1)
  200.  7006 CONTINUE
  201.   17  CONTINUE
  202. *
  203. *     ON A TROUVE UNE BIJECTION   ET ON VECTORISE
  204. *
  205.       N1=NSOUS1
  206.       N1PTEL=0
  207.       N1EL=0
  208.       N=1
  209.       SEGINI KEVOLL
  210.       NUMEVY='REEL'
  211.       TYPX='LISTREEL'
  212.       TYPY='LISTREEL'
  213.       NOMEVX=NCOPO
  214.       NOMEVY=NOMCH1
  215.       IPROGX=MLABS
  216.       NUMEVX=IDCOUL
  217.       KEVOL1=KEVOLL
  218.       SEGINI MCHELM
  219.       TITCHE=MOT
  220.       IFOCHE=IFOUR
  221.       DO 400 ISOUS=1,NSOUS1
  222.          IMACHE(ISOUS)=MCHEL1.IMACHE(ISOUS)
  223.          CONCHE(ISOUS)=MCHEL1.CONCHE(ISOUS)
  224.          DO 401 N33=1,N3
  225.                INFCHE(ISOUS,N33)=MCHEL1.INFCHE(ISOUS,N33)
  226.  401     CONTINUE
  227.          MCHAM1=MCHEL1.ICHAML(ISOUS)
  228.          SEGINI,MCHAML=MCHAM1
  229.          ICHAML(ISOUS)=MCHAML
  230.          TYPCHE='POINTEUREVOLUTIO'
  231.          MELVA1=MCHAM1.IELVAL(1)
  232.          SEGACT MELVA1
  233.          N2PTEL=MELVA1.VELCHE(/1)
  234.          N2EL=MELVA1.VELCHE(/2)
  235.          SEGINI MELVAL
  236.          IELVAL(1)=MELVAL
  237.          SEGDES MCHAML
  238.          DO 7021 I=1,NNCH
  239.          MELVA1=JTAFF(ISOUS,I)
  240.          SEGACT MELVA1
  241.  7021    CONTINUE
  242.          DO 7010 IAEL=1,N2EL
  243.          DO 7010 IAPT=1,N2PTEL
  244.          SEGINI MEVOLL
  245.          ITYEVO='REEL'
  246.          IELCHE(IAPT,IAEL)=MEVOLL
  247.          SEGINI,KEVOLL=KEVOL1
  248.          SEGINI MLREEL
  249.          IPROGY=MLREEL
  250.          IEVOLL(1)= KEVOLL
  251.          DO 7011 I=1,NNCH
  252.          MELVA1=JTAFF(ISOUS,I)
  253.          PROG(I)= MELVA1.VELCHE(IAPT,IAEL)
  254.  7011    CONTINUE
  255.          SEGDES MLREEL
  256.          SEGDES KEVOLL,MEVOLL
  257.  7010    CONTINUE
  258.          DO 7022 I=1,NNCH
  259.          MELVA1=JTAFF(ISOUS,I)
  260.          SEGDES MELVA1
  261.  7022    CONTINUE
  262.          SEGDES MELVAL
  263.   400    CONTINUE
  264.          SEGDES MCHELM
  265.          MRES=MCHELM
  266. *
  267. *     desactivation
  268. *
  269.        SEGSUP ITAFF
  270.        DO 7030 I=1,IPC(/1)
  271.        MCHELM=IPC(I)
  272.        DO 7031 IK=1,ICHAML(/1)
  273.        MCHAML=ICHAML(IK)
  274.        SEGDES MCHAML
  275.  7031  CONTINUE
  276.        SEGDES MCHELM
  277.  7030  CONTINUE
  278.        SEGSUP IDONN
  279.        CALL ECROBJ('MCHAML   ',MRES)
  280.       RETURN
  281.       END
  282.  
  283.  
  284.  
  285.  
  286.  
  287.  
  288.  
  289.  
  290.  
  291.  
  292.  
  293.  
  294.  
  295.  
  296.  
  297.  
  298.  
  299.  
  300.  
  301.  

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