MINICERN/mathlib/gen/u/clebs.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1996/04/01 15:01:45  mclareni
   6 * Mathlib gen
   7 *
   8 *
   9 *FCA :          Fri Mar 26 17:27:50 CET 1999 by  Federico Carminati
  10 *               Removed vzero and ucopy
  11 #include "gen/pilot.h"
  12       SUBROUTINE CLEBS(J1,J2,J3,JM1,JM2, JM3,K,M)
  13 C*NS  DIMENSION L1(40),L2(40),IB(40),K(2),LS(40,11),LD(40,6),IIL(40,2),
  14 C*NS F                LLSN(40),LLSD(40),IL(2),LL(40),LR(40,100),LQ(40),
  15       DIMENSION               IB(40),K(2),LS(40,11),LD(40,6),IIL(40,2),
  16      F                LLSN(40),LLSD(40),      LL(40),LR(40,100),LQ(40),
  17      F IS(100),ISK(40),M(41)
  18 C*NS  DIMENSION LR1(40),ICGC(40)
  19       DIMENSION         ICGC(40)
  20       IF((JM1+JM2).NE.JM3)     GO TO 1
  21       CALL U100PR(J3+1,LS(1,1),ID)
  22       CALL U100FC((J3+J1-J2)/2,LS(1,2))
  23       CALL U100FC((J3-J1+J2)/2,LS(1,3))
  24       CALL U100FC((J1+J2-J3)/2,LS(1,4))
  25       CALL U100FC((J3+JM3)/2,LS(1,5))
  26       CALL U100FC((J3-JM3)/2,LS(1,6))
  27       CALL U100FC((J1+J2+J3)/2+1,LS(1,7))
  28       CALL U100FC((J1-JM1)/2,LS(1,8))
  29       CALL U100FC((J1+JM1)/2,LS(1,9))
  30       CALL U100FC((J2-JM2)/2,LS(1,10))
  31       CALL U100FC((J2+JM2)/2,LS(1,11))
  32       DO 2    LZ=1,11
  33       IF (LS(1,LZ) .EQ. (-77))   GO TO 45
  34     2 CONTINUE
  35       DO KZERO=1,40
  36          M(KZERO)=0
  37          LLSN(KZERO)=0
  38          LLSD(KZERO)=0
  39       ENDDO
  40       M(41)=0
  41 *     CALL VZERO (M,41)
  42 *     CALL VZERO (LLSN,40)
  43 *     CALL VZERO (LLSD, 40)
  44       DO 5  J=1,40
  45       DO 5 I=1,6
  46     5 LLSN(J)=LLSN(J)+LS(J,I)
  47       DO 6  J=1,40
  48       DO 6  I=7,11
  49     6 LLSD(J)=LLSD(J)+LS(J,I)
  50       CALL U100DV(LLSN,LLSD,LL)
  51       MJ=1
  52       N=-1
  53       MM=0
  54     3 N=N+1
  55       CALL U100FC((J2+J3+JM1)/2-N,LD(1,1))
  56       CALL U100FC((J1-JM1)/2+N,LD(1,2))
  57       CALL U100FC(N,LD(1,3))
  58       CALL U100FC((J3-J1+J2)/2-N,LD(1,4))
  59       CALL U100FC((J3+JM3)/2-N,LD(1,5))
  60       CALL U100FC((J1-J2-JM3)/2+N,LD(1,6))
  61       IF(LD(1,1).EQ.(-77))    GO TO 4
  62       IF(LD(1,4).EQ.(-77))    GO TO 4
  63       IF(LD(1,5).EQ.(-77))    GO TO 4
  64       IF(LD(1,2).EQ.(-77))  GO TO 3
  65       IF(LD(1,6).EQ.(-77))  GO TO 3
  66       MM=MM+1
  67       IS(MM)=(-1)**(N+(J2+JM2)/2)
  68       DO 7    JK=1,40
  69       IIL(JK,1)=LD(JK,1)+LD(JK,2)
  70     7 IIL(JK,2)=LD(JK,3)+LD(JK,4)+LD(JK,5)+LD(JK,6)
  71       CALL U100DV (IIL(1,1),IIL(1,2),LR(1,MM))
  72       GO TO 3
  73     4 DO 31 JJ=1,40
  74       IB(JJ)=10000
  75       DO 31  JK=1,MM
  76       IF (LR(JJ,JK) .LT. IB(JJ))   IB(JJ)=LR(JJ,JK)
  77    31 CONTINUE
  78       ISUM=0
  79       DO 32 JM=1,MM
  80       DO 33 IO=1,40
  81    33 LQ(IO)=LR(IO,JM)-IB(IO)
  82       CALL U100PM(LQ,K(1),K(2))
  83    32 ISUM=ISUM+K(1)*IS(JM)
  84       IX=ABS(ISUM)
  85       IF(IX.EQ.0) GO TO 1
  86       CALL U100PR(IX,ISK,IP)
  87       DO 22 LK=1,40
  88    22 ICGC(LK)=LL(LK)+2*IB(LK)+2*ISK(LK)
  89       IXX=IP*   ISUM/ABS(ISUM)
  90       ISIGN=ISUM/ABS(ISUM)
  91       IXXX=IP*ISIGN
  92       M(41)=IXXX
  93       DO KCOPY=1,40
  94          M(KCOPY)=ICGC(KCOPY)
  95       ENDDO
  96 *     CALL UCOPY (ICGC, M, 40)
  97       CALL U100PM(ICGC,K(1),K(2))
  98       K(1)=K(1)*IXX
  99       RETURN
 100    45 WRITE(6,50)
 101    50 FORMAT(1H ,'CHECK YOUR PARAMETERS ONCE MORE'///)
 102     1 K(1)=0
 103       K(2)=1
 104       RETURN
 105       END