C OOOADI SOURCE PV090527 26/05/07 21:15:05 12532 ** SUBROUTINE OOOADG (ISSG,TYLN,NELM,IDOB,IDOA) SUBROUTINE OOOADI (LLL,LL2,LL1,III,II2,II1,RRR,RR8,R16,CCC,C16, >C32,CAR,TYLN,NELM,IDOB,IDOA) C---------------------------------------------------------------------- C C DECALAGE A GAUCHE POUR OOOYAD C XXX(IDOB+I)=XXX(IDOA+I) POUR : I=1,NELM C C ISSG POINTEUR SUR LE SEGMENT CONTENANT LA ZONE A DECALER C IDOB DEPLACEMENT DESTINATION DANS LE SEGMENT C IDOA DEPLACEMENT EMISSION DANS LE SEGMENT C NELM NOMBRE D'ELEMENTS A DEPLACER C TYLN TYPE DES ELEMENTS DU SEGMENT (1 A 13) (LOGICAL A CHARACTER) C * avec unrolling PV 1/2020 MACRO , ( LOGICAL , LOGICAL 2 , LOGICAL 1 2 , INTEGER , INTEGER 2 , INTEGER 1 3 , REAL , REAL 8 , REAL 16 4 , COMPLEX , COMPLEX16 , COMPLEX32 5 , CHARACTER ) C ** SEGMENT , LLL(0)*L , LL2(0)*L2 , LL1(0)*L1 ** SEGMENT , III(0)*I , II2(0)*I2 , II1(0)*I1 ** SEGMENT , RRR(0)*R , RR8(0)* D , R16(0)* Q ** SEGMENT , CCC(0)*C , C16(0)*CD , C32(0)*CQ ** SEGMENT /SCH/ (CAR *(1)) ** EQUIVALENCE ( LLL , LL2 , LL1 ,ISEG) ** EQUIVALENCE ( III , II2 , II1 ,ISEG) ** EQUIVALENCE ( RRR , RR8 , R16 ,ISEG) ** EQUIVALENCE ( CCC , C16 , C32 ,ISEG) ** EQUIVALENCE ( SCH ,ISEG) C logical lll(*) logical*2 ll2(*) logical*1 ll1(*) integer iii(*) integer*2 ii2(*) integer*1 ii1(*) real rrr(*) real*8 rr8(*) ** real*16 r16(*) complex ccc(*) complex*16 c16(*) complex*16 c32(*) character*(*) car CHARACTER*1 H1 INTEGER TYLN SEGMENT , ISSG(0)*I , ISEG(0)*I C ** ISEG=ISSG CASE , TYLN WHEN , LOGICAL DO I=1,NELM LLL(IDOB+I)=LLL(IDOA+I) ENDDO WHEN , LOGICAL 2 DO I=1,NELM LL2(IDOB+I)=LL2(IDOA+I) ENDDO WHEN , LOGICAL 1 DO I=1,NELM LL1(IDOB+I)=LL1(IDOA+I) ENDDO WHEN , INTEGER ** DO I=1,NELM ** III(IDOB+I)=III(IDOA+I) ** ENDDO DO I=1,NELM-3,4 III(IDOB+I)=III(IDOA+I) III(IDOB+I+1)=III(IDOA+I+1) III(IDOB+I+2)=III(IDOA+I+2) III(IDOB+I+3)=III(IDOA+I+3) ENDDO j=i DO i=j,NELM III(IDOB+i)=III(IDOA+i) ENDDO WHEN , INTEGER 2 DO I=1,NELM II2(IDOB+I)=II2(IDOA+I) ENDDO WHEN , INTEGER 1 DO I=1,NELM II1(IDOB+I)=II1(IDOA+I) ENDDO WHEN , REAL ** DO I=1,NELM ** RRR(IDOB+I)=RRR(IDOA+I) ** ENDDO DO I=1,NELM-3,4 RRR(IDOB+I)=RRR(IDOA+I) RRR(IDOB+I+1)=RRR(IDOA+I+1) RRR(IDOB+I+2)=RRR(IDOA+I+2) RRR(IDOB+I+3)=RRR(IDOA+I+3) ENDDO j=i DO I=j,NELM RRR(IDOB+I)=RRR(IDOA+I) ENDDO WHEN , REAL 8 ** DO I=1,NELM ** RR8(IDOB+I)=RR8(IDOA+I) ** ENDDO DO I=1,NELM-3,4 RR8(IDOB+I)=RR8(IDOA+I) RR8(IDOB+I+1)=RR8(IDOA+I+1) RR8(IDOB+I+2)=RR8(IDOA+I+2) RR8(IDOB+I+3)=RR8(IDOA+I+3) ENDDO j=i DO I=j,NELM RR8(IDOB+I)=RR8(IDOA+I) ENDDO WHEN , REAL 16 DO I=1,NELM ** R16(IDOB+I)=R16(IDOA+I) ENDDO WHEN , COMPLEX DO I=1,NELM CCC(IDOB+I)=CCC(IDOA+I) ENDDO WHEN , COMPLEX16 DO I=1,NELM C16(IDOB+I)=C16(IDOA+I) ENDDO WHEN , COMPLEX32 DO I=1,NELM C32(IDOB+I)=C32(IDOA+I) ENDDO WHEN , CHARACTER DO I=1,NELM H1 =CAR(IDOA+I:IDOA+I) CAR(IDOB+I:IDOB+I)=H1 ENDDO ENDCASE RETURN C----------------------------------------------------------------------- C C DECALAGE A DROITE POUR OOOYAD C XXX(IDOB+I)=XXX(IDOA+I) POUR : I=NELM,1,-1 C ** ENTRY OOOADD (ISSG,TYLN,NELM,IDOB,IDOA) ENTRY OOOADH (LLL,LL2,LL1,III,II2,II1,RRR,RR8,R16,CCC,C16, >C32,CAR,TYLN,NELM,IDOB,IDOA) C ** ISEG=ISSG CASE , TYLN WHEN , LOGICAL DO I=NELM,1,-1 LLL(IDOB+I)=LLL(IDOA+I) ENDDO WHEN , LOGICAL 2 DO I=NELM,1,-1 LL2(IDOB+I)=LL2(IDOA+I) ENDDO WHEN , LOGICAL 1 DO I=NELM,1,-1 LL1(IDOB+I)=LL1(IDOA+I) ENDDO WHEN , INTEGER ** DO I=NELM,1,-1 ** III(IDOB+I)=III(IDOA+I) ** ENDDO DO I=NELM,3,-4 III(IDOB+I)=III(IDOA+I) III(IDOB+I-1)=III(IDOA+I-1) III(IDOB+I-2)=III(IDOA+I-2) III(IDOB+I-3)=III(IDOA+I-3) ENDDO j=i DO i=j,1,-1 III(IDOB+i)=III(IDOA+i) ENDDO WHEN , INTEGER 2 DO I=NELM,1,-1 II2(IDOB+I)=II2(IDOA+I) ENDDO WHEN , INTEGER 1 DO I=NELM,1,-1 II1(IDOB+I)=II1(IDOA+I) ENDDO WHEN , REAL ** DO I=NELM,1,-1 ** RRR(IDOB+I)=RRR(IDOA+I) ** ENDDO DO I=NELM,3,-4 RRR(IDOB+I)=RRR(IDOA+I) RRR(IDOB+I-1)=RRR(IDOA+I-1) RRR(IDOB+I-2)=RRR(IDOA+I-2) RRR(IDOB+I-3)=RRR(IDOA+I-3) ENDDO j=i DO I=j,1,-1 RRR(IDOB+I)=RRR(IDOA+I) ENDDO WHEN , REAL 8 ** DO I=NELM,1,-1 ** RR8(IDOB+I)=RR8(IDOA+I) ** ENDDO DO I=NELM,3,-4 RR8(IDOB+I)=RR8(IDOA+I) RR8(IDOB+I-1)=RR8(IDOA+I-1) RR8(IDOB+I-2)=RR8(IDOA+I-2) RR8(IDOB+I-3)=RR8(IDOA+I-3) ENDDO j=i DO I=j,1,-1 RR8(IDOB+I)=RR8(IDOA+I) ENDDO WHEN , REAL 16 DO I=NELM,1,-1 ** R16(IDOB+I)=R16(IDOA+I) ENDDO WHEN , COMPLEX DO I=NELM,1,-1 CCC(IDOB+I)=CCC(IDOA+I) ENDDO WHEN , COMPLEX16 DO I=NELM,1,-1 C16(IDOB+I)=C16(IDOA+I) ENDDO WHEN , COMPLEX32 DO I=NELM,1,-1 C32(IDOB+I)=C32(IDOA+I) ENDDO WHEN , CHARACTER DO I=NELM,1,-1 H1 =CAR(IDOA+I:IDOA+I) CAR(IDOB+I:IDOB+I)=H1 ENDDO ENDCASE RETURN C----------------------------------------------------------------------- C C REMISE A 0 OU BLANC POUR OOOYAD C XXX(IDOB+I)= NULL? POUR : I=1,NELM C ** ENTRY OOOADZ (ISSG,TYLN,NELM,IDOB) ENTRY OOOADY (LLL,LL2,LL1,III,II2,II1,RRR,RR8,R16,CCC,C16, >C32,CAR,TYLN,NELM,IDOB) C ** ISEG=ISSG CASE , TYLN WHEN , LOGICAL DO I=1,NELM LLL(IDOB+I)=.FALSE. ENDDO WHEN , LOGICAL 2 DO I=1,NELM LL2(IDOB+I)=.FALSE. ENDDO WHEN , LOGICAL 1 DO I=1,NELM LL1(IDOB+I)=.FALSE. ENDDO WHEN , INTEGER DO I=1,NELM III(IDOB+I)=0 ENDDO WHEN , INTEGER 2 DO I=1,NELM II2(IDOB+I)=0 ENDDO WHEN , INTEGER 1 DO I=1,NELM II1(IDOB+I)=0 ENDDO WHEN , REAL DO I=1,NELM RRR(IDOB+I)=0. ENDDO WHEN , REAL 8 DO I=1,NELM RR8(IDOB+I)=0. ENDDO WHEN , REAL 16 DO I=1,NELM ** R16(IDOB+I)=0. ENDDO WHEN , COMPLEX DO I=1,NELM CCC(IDOB+I)=(0.,0.) ENDDO WHEN , COMPLEX16 DO I=1,NELM C16(IDOB+I)=(0.,0.) ENDDO WHEN , COMPLEX32 DO I=1,NELM C32(IDOB+I)=(0.,0.) ENDDO WHEN , CHARACTER DO I=1,NELM CAR(IDOB+I:IDOB+I)=' ' ENDDO ENDCASE RETURN END