diff options
Diffstat (limited to 'Utilib/src/XDRSDB.f')
| -rw-r--r-- | Utilib/src/XDRSDB.f | 51 |
1 files changed, 51 insertions, 0 deletions
diff --git a/Utilib/src/XDRSDB.f b/Utilib/src/XDRSDB.f new file mode 100644 index 0000000..345b3f1 --- /dev/null +++ b/Utilib/src/XDRSDB.f @@ -0,0 +1,51 @@ +*DECK XDRSDB + SUBROUTINE XDRSDB(NBELEM,RVECT,DBVECT,KDIR) +C +C--------------------------- XDRSDB --------------------------------- +C +C 1- PROGRAMME STATISTICS: +C +C NAME : XDRSDB +C FUNCTION : DOUBLE PRECISION TO/FROM SIMPLE PRECISION +C DATE : 20-02-1987 +C AUTHOR : G.MARLEAU +C +C 2- INPUT AND OUTPUT PARAMETERS: +C +C NBELEM : NUMBER OF WORDS TO TRANSLATE +C RVECT : SIMPLE PRECISION VECTOR - RVECT(NBELEM) +C DBVECT : DOUBLE PRECISION VECTOR - DBRVECT(NBELEM) +C KDIR : DIRECTION OF TRANSLATION +C : KDIR = 1 FROM DOUBLE TO SIMPLE PRECISION +C : KDIR = 2 FROM SIMPLE TO DOUBLE PRECISION +C +C--------------------------- XDRSDB -------------------------------- +C + CHARACTER CERROR*4 + INTEGER NBELEM,KDIR + REAL RVECT(*) + DOUBLE PRECISION DBVECT(*) + IF(KDIR.EQ.1) THEN +C------ +C FROM DOUBLE TO SIMPLE PRECISION +C------ + DO 100 IELEM=1,NBELEM + RVECT(IELEM)=REAL(DBVECT(IELEM)) + 100 CONTINUE + ELSE IF(KDIR.EQ.2) THEN +C------ +C FROM SIMPLE TO DOUBLE PRECISION +C------ + DO 200 IELEM=NBELEM,1,-1 + DBVECT(IELEM)=DBLE(RVECT(IELEM)) + 200 CONTINUE + ELSE +C------ +C INVALID VALUE FOR KDIR +C------ + WRITE(CERROR,'(I4)') KDIR + CALL XABORT('XDRSDB: ONLY KDIR=1 AND KDIR=2 ALLOWED; KDIR=' + > //CERROR//' FOUND') + ENDIF + RETURN + END |