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

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