https://github.com/Unipisa/TAUmus
Raw File
Tip revision: be97ff85eb836773e0af90490bea376e52fce579 authored by Pietro Grossi on 16 October 1972, 08:54:00 UTC
v1.1 -
Tip revision: be97ff8
SUBROUTINE_CALMUS.FOR
    SUBROUTINE CALMUS
    COMMON FR,T  ,R,S,INIZ,IFIN,IPAS,IDENT(2),BATS,RDCND,MA,KS
    *ALR,DURA,NOA,IP,KONT
    DIMENSION NNN(1700),I(10),NN(10),FFRE(20),TT(20),III(20),
1   FR (5000) ,T(5000) NPLLOD
    REAL KFT(8)
    READ(5,10)N,N1,N2
10  FORMAT(3I4)
    N=4
    LN=1
    KK=0
    KONT=0
    KKONT=0
    L=0
    LL=0
    KP=0
8   K=0
11  K=K+1
    IF(K.LE.N)GO TO 12
    LN=LN+1
    IF(LN.GT.5)GO TO 50
    GO TO 8
12  DO L5 M=1,K
15  I(M)=1
20  KK=KK+1
    NNN(KK)=0
    DO 30 J=1,K
    NN(J)=I(J)*(10**(J-1))
30  NNN(KK)=NNN(KK)+NN(J)
    LL=LL+1
    III(LL)=NNN(KK)
    IF(LL.LT.20)GO TO 33
    WR ITF(6,1)(III(LL),LL=1,20)
1   FORMAT(1X,20I6)
    LL=0
33  DO 35 M=1,K
    I(M)=I(M)+1
    IF(I(M).LE.N) GO TO 20
35  I(M)=1
    GO TO 11
50  N2=N2*23
    N1=(N1*23)+(N2/10000)
    N2=IABS(M0D(N2,10000)-(N1/10000))
    IF(N2.LE.0)N2=1000
    N1=MOD(N1,10000)
    IF(N1.LE.0)N1=1000
    NP(2)=N1/100
    NP(4)=MOD(NT,100)
    NP(6)=N2/100
    NP(8)=M0D(N2,100}
    DO 40 II=2,8,2
    IF(NP(II).EQ.0)NP(II)=1
40  CONTINUE
    IF(L.NE.0)G0 TO 60
    KP=KP+1
    FFR(KP)=FLOAT(NP(2))*FLOAT(NP(4))/2.
    TT(KP)=FLOAT(NP(4))/FLOAT(NP(6))/10.*0.2
    WRITE(6,2)KP,FFR(KP),TT(KP)
2   FORMAT ( 1Xy 14, 2F10.3)
    IF(KP.LT.20)GO TO 50
    L=1
    IF(N2.GT.99)N2=99
    JI=N2
    GO TO 50
60  IF(NP(8).EQ.99)KJ=N1/1000
    IF(NP(8).GE.97.AND.NP(8).LE.98)KJ=N1/100
    IF(NP(8).GE.77.AND.NP(8).LE.96)KJ=N1/10
    IF(NP(8).LE.76)KJ=N1
    IF(KJ.GT.1700)GO TO 50
    IF(KJ.LE.0)GO TO 50
80  J=5
    DO 110 JJ=1,7,2
90  J=J-1
    IF(J.EQ.0)GO TO 120
    MM=MOD(NNN(KJ),(10**J))/(10**(J-1))
    IF(MM,EQ.0)G0 TO 90
    LI=0
92  LI=LI+1
    IF(KJ.LE.(340*LI))GO TO 95
    MM=MM+4
    GO TO 92
95  KONT=KONT+1
    FR(KONT)=FFR(MM)
    T(KONT)=TT(MM)
    KFT(JJ)=FR(KONT)
    KFT(JJ+1)=T(KONT)
    JK=JJ+1
110 CONTINUE
    KKONT=KKONT+1
120 WRITE(6,3)KKONT,KJ,(KFT(J),J=1,JK)
3   FORMAT(1X,2I6,8F12,3)
    IF(KONT.GE.5000)GO TO 70
    IF(KKONT.LT.JI)GO TO 50
70  JJJ=KONT
    CALL DECOD(FR,T,JJJ)
    RETURN
    END
back to top