1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
|
*DECK DRVMPX
SUBROUTINE DRVMPX(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY)
*
*-----------------------------------------------------------------------
*
* STANDARD MULTIPLICATION MODULE.
*
* INPUT/OUTPUT PARAMETERS:
* NENTRY : NUMBER OF LINKED LISTS AND FILES USED BY THE MODULE.
* HENTRY : CHARACTER*12 NAME OF EACH LINKED LIST OR FILE.
* IENTRY : =0 CLE-2000 VARIABLE; =1 LINKED LIST; =2 XSM FILE;
* =3 SEQUENTIAL BINARY FILE; =4 SEQUENTIAL ASCII FILE.
* JENTRY : =0 THE LINKED LIST OR FILE IS CREATED.
* =1 THE LINKED LIST OR FILE IS OPEN FOR MODIFICATIONS;
* =2 THE LINKED LIST OR FILE IS OPEN IN READ-ONLY MODE.
* KENTRY : =FILE UNIT NUMBER; =LINKED LIST ADDRESS OTHERWISE.
* DIMENSION HENTRY(NENTRY),IENTRY(NENTRY),JENTRY(NENTRY),
* KENTRY(NENTRY)
*
*-------------------------------------- AUTHOR: A. HEBERT ; 23/07/94 ---
*
USE GANLIB
*----
* SUBROUTINE ARGUMENTS
*----
INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY)
TYPE(C_PTR) KENTRY(NENTRY)
CHARACTER HENTRY(NENTRY)*12
*----
* LOCAL VARIABLES
*----
TYPE(C_PTR) IPLIST1
CHARACTER HSMG*131,TEXT4*4,TEXT12*12
DOUBLE PRECISION DFLOTT
*
* PARAMETER VALIDATION.
IF(NENTRY.EQ.0) CALL XABORT('DRVMPX: ONE PARAMETER EXPECTED.')
TEXT12=HENTRY(1)
IF((JENTRY(1).EQ.2).OR.(IENTRY(1).GT.2)) CALL XABORT('DRVMPX: LIN'
1 //'KED LIST OR XSM FILE IN CREATION OR MODIFICATION MODE EXPECTE'
2 //'D AT LHS ('//TEXT12//').')
*
* COPY THE RHS INTO THE LHS.
IF(JENTRY(1).EQ.0) THEN
IF(NENTRY.LE.1) CALL XABORT('DRVMPX: TWO PARAMETERS EXPECTED.')
IF((JENTRY(2).NE.2).OR.(IENTRY(2).GT.2)) CALL XABORT('DRVMPX: '
1 //'LINKED LIST OR XSM FILE IN READ-ONLY MODE EXPECTED AT RHS.')
NUNIT=KDROPN('DUMMYSQ',0,2,0)
IF(NUNIT.LE.0) CALL XABORT('DRVMPX: KDROPN FAILURE.')
CALL LCMEXP(KENTRY(2),0,NUNIT,1,1)
REWIND(NUNIT)
CALL LCMEXP(KENTRY(1),0,NUNIT,1,2)
IERR=KDRCLS(NUNIT,2)
IF(IERR.LT.0) THEN
WRITE(HSMG,'(29HDRVMPX: KDRCLS FAILURE. IERR=,I3)') IERR
CALL XABORT(HSMG)
ENDIF
ENDIF
*
* READ THE REAL NUMBER
CALL REDGET(ITYP,NITMA,FLOTT,TEXT4,DFLOTT)
IF(ITYP.NE.2) CALL XABORT('DRVMPX: REAL DATA EXPECTED.')
CALL REDGET(ITYP,NITMA,FLOTT,TEXT4,DFLOTT)
IF((ITYP.NE.3).OR.(TEXT4.NE.';')) THEN
CALL XABORT('DRVMPX: ; EXPECTED.')
ENDIF
*
* PERFORM THE MULTIPLICATION.
IPLIST1=KENTRY(1)
CALL LCMULT(IPLIST1,FLOTT)
RETURN
END
|
