Télécharger la plaquette Cast3M


fr en

Télécharger pfmors.eso

Retour à la liste

Numérotation des lignes : 

pfmors

  1. C PFMORS    SOURCE    PV        20/09/26    21:19:06     10724          
  2.       SUBROUTINE PFMORS(ASSTAB,MATRIK,LL)
  3.       IMPLICIT INTEGER(I-N)
  4.       IMPLICIT REAL*8 (A-H,O-Z)
  5. C     ******************************************
  6. C     * Subroutine calculant le profil morse   *
  7. C     * a partir de ASSTAB                     *
  8. C     * Entree /Sortie : MATRIK                *
  9. C     * Sortie : ASSTAB                        *
  10. C     ******************************************
  11.  
  13.  
  14.       SEGMENT ASSTAB
  15.       INTEGER ITAB(NBCOMP,NTA)
  16.       ENDSEGMENT
  17.  
  18.       INTEGER DUA,PRI,MAXDUA,MAXPRI
  19.  
  20.       SEGACT MATRIK*MOD
  21.       SEGACT ASSTAB
  22.  
  23.       NBCOMP=ITAB(/1)
  24.       NTA=ITAB(/2)
  25.  
  26.       MINCP=KMINCP
  27.       MINCD=KMINCD
  28.  
  29.       SEGACT MINCP,MINCD
  30.       NPTP=MINCP.MPOS(/1)
  31.       NPTD=MINCD.MPOS(/1)
  32.       NBIP=MINCP.MPOS(/2)-1
  33.       NBID=MINCD.MPOS(/2)-1
  34.  
  35.       NTT=NPTD
  36.       NJA=NPTP
  37. C     On initialise le segment PMORS
  38.       SEGINI PMORS
  39.  
  40.       M=0
  41.       MAXPRI=0
  42.       MAXDUA=0
  43.  
  44.  
  45.       DO I=1,NTA
  46.          NB=ITAB(1,I)
  47.          NINCD=MINCD.NPOS(I+1)-MINCD.NPOS(I)
  48.  
  49. c         WRITE(6,*) 'NINCD',NINCD
  50.          LLL=0
  51.          DO L=1,NINCD
  52.             LLL=LLL+1
  53.  300        CONTINUE
  54.             IF (MINCD.MPOS(I,LLL).EQ.0) THEN
  55.                LLL=LLL+1
  56.                GOTO 300
  57.             END IF
  58.             DUA=MINCD.NPOS(I)+MINCD.MPOS(I,LLL)-1
  59.             MAXDUA=MAX(DUA,MAXDUA)
  60.  
  61.  100        CONTINUE
  62.             IF (NTT.LT.DUA) THEN
  63.                NTT=NTT+100
  64.                SEGADJ PMORS
  65.                GOTO 100
  66.             END IF
  67. c            WRITE(6,*) 'DUA',DUA,'M',M
  68.             IA(DUA)=M+1
  69. c            WRITE(6,*) 'NB', NB
  70.  
  71.             DO J=1,NB
  72. c               WRITE(6,*) 'J',J,'I',I
  73.                PRI=ITAB(J+1,I)
  74. c               WRITE(6,*) 'PRI',PRI,'NINCP',MINCP.NPOS(PRI+1)-
  75. c     &              MINCP.NPOS(PRI)
  76.                NINCP=MINCP.NPOS(PRI+1)-MINCP.NPOS(PRI)
  77.  
  78.                KK=0
  79.                DO K=1,NINCP
  80.                   KK=KK+1
  81.                   PRI=ITAB(J+1,I)
  82.                   M=M+1
  83. c                  WRITE(6,*) 'M',M
  84.  200              CONTINUE
  85.                   IF (NJA.LT.M) THEN
  86.                      NJA=NJA+100
  87.                      SEGADJ PMORS
  88.                      GOTO 200
  89.                   END IF
  90. c                  WRITE(6,*) 'PRI',PRI,'MINCP.NPOS(PRI)',
  91. c     &                 MINCP.NPOS(PRI),
  92. c     &               'MINCP.MPOS(PRI,K)',MINCP.MPOS(PRI,K)
  93.  350              CONTINUE
  94.                   IF (MINCP.MPOS(PRI,KK).EQ.0) THEN
  95.                      KK=KK+1
  96.                      GOTO 350
  97.                   END IF
  98.  
  99.                   PRI=MINCP.NPOS(PRI)+MINCP.MPOS(PRI,KK)-1
  100. c                  WRITE(6,*) 'M',M,'PRI',PRI
  101.                   MAXPRI=MAX(MAXPRI,PRI)
  102.                   JA(M)=PRI
  103.                END DO
  104.             END DO
  105.          END DO
  106.       END DO
  107.  
  108.  
  109.       NTT=MAXDUA
  110.       NJA=M
  111.  
  112.       SEGADJ PMORS
  113. C     On oublie pas le dernier
  114.       IA(MAXDUA+1)=M+1
  115.  
  116.       SEGDES PMORS
  117.       SEGDES MINCP,MINCD
  118.       SEGSUP ASSTAB
  119.  
  120.       IRIGEL(5,LL)=PMORS
  121.       KNTTP=MAXPRI
  122.       KNTTD=MAXDUA
  123.       SEGDES MATRIK
  124.       RETURN
  125.  
  126.       END
  127.  
  128.  
  129.  
  130.  
  131.  
  132.  
  133.  

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