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

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