Skip to content

Commit e93db69

Browse files
schwickeschwicke
committed
Add some basic Fortran tests
1 parent 1a3ea1d commit e93db69

10 files changed

Lines changed: 1870 additions & 0 deletions

File tree

‎src/test_f/test_f10.f‎

Lines changed: 146 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,146 @@
1+
C *****************************************************************************
2+
C * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS HEADER
3+
C *
4+
C * This file is part of Open PHIGS
5+
C * Copyright (C) 2022-2023 CERN
6+
C *
7+
C * Open PHIGS is free software: you can redistribute it and/or modify
8+
C * it under the terms of the GNU Lesser General Public License as published by
9+
C * the Free Software Foundation, either version 2.1 of the License, or
10+
C * (at your option) any later version.
11+
C *
12+
C * Open PHIGS is distributed in the hope that it will be useful,
13+
C * but WITHOUT ANY WARRANTY; without even the implied warranty of
14+
C * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15+
C * GNU Lesser General Public License for more details.
16+
C *
17+
C * You should have received a copy of the GNU Lesser General Public License
18+
C * along with Open PHIGS. If not, see <http://www.gnu.org/licenses/>.
19+
C *****************************************************************************
20+
21+
PROGRAM VALUATOR
22+
IMPLICIT NONE
23+
24+
C Include PHIGS enumeration file
25+
INCLUDE 'phigsf77.h'
26+
27+
C Delcare variables
28+
CHARACTER(LEN=80) DATREC(10)
29+
INTEGER I, WKID, IERR, ISTAT, VLDNR
30+
INTEGER LDR, PET
31+
INTEGER MLDR
32+
REAL EVOL(6), RA(2), DEFAULT, VALUE
33+
INTEGER LSTR(4)
34+
PARAMETER(MLDR=20)
35+
CHARACTER*20 config(4)
36+
DATA CONFIG /"Input:", "%8.3g", "min", "max"/
37+
C Delcare arrays
38+
REAL COLR(1:3)
39+
REAL TIMOUT
40+
INTEGER WKIDI, ICL, IDEV
41+
INTEGER NSLID
42+
43+
C Set some parameters
44+
C Workstation ID
45+
WKID=1
46+
C Initial value
47+
DEFAULT = 30.
48+
C First Device ID
49+
VLDNR = 1
50+
C Number of sliders to create
51+
NSLID = 5
52+
53+
C Open PHIGS and a workstation
54+
CALL POPPH(0, 1)
55+
CALL POPWK(WKID, 0, 3)
56+
C Define colour in workstation table
57+
COLR(1) = 1.0
58+
COLR(2) = 0.0
59+
COLR(3) = 0.0
60+
CALL PSCR(WKID, 1, 3, COLR)
61+
62+
C Open structure
63+
CALL POPST(0)
64+
65+
C Set background color to white
66+
COLR(1) = 1.0
67+
COLR(2) = 1.0
68+
COLR(3) = 1.0
69+
CALL PSCR(WKID, 0, 3, COLR)
70+
71+
C Set text attributes
72+
CALL PSCHH(0.04)
73+
74+
C Draw text
75+
CALL PSTXCI(1)
76+
CALL PTX(0.22, 0.48, 'Testing valuator')
77+
78+
C Close structure
79+
CALL PCLST
80+
81+
C Post structure to workstation
82+
CALL PPOST(WKID, 0, 0.0)
83+
84+
C initialise data: real string lengths
85+
LSTR(1)=6
86+
LSTR(2)=5
87+
LSTR(3)=3
88+
LSTR(4)=3
89+
C scale from .. to
90+
RA(1) = 0.
91+
RA(2) = 100.
92+
C encode it
93+
CALL PPREC(1, NSLID, 2, RA, 4, LSTR, CONFIG,
94+
+ MLDR, IERR, LDR, DATREC)
95+
C for echo type 1 and -1:
96+
C * display in dedicated window
97+
C * echo volume absolute in device coordinates (DC)
98+
PET = -1
99+
EVOL(1) = 1200.0
100+
EVOL(2) = 1500.0
101+
EVOL(3) = 1000.0
102+
EVOL(4) = 1030.0
103+
EVOL(5) = 0.
104+
EVOL(6) = 1.
105+
C for echo type -1: as for 1 but we can specify the strings
106+
PET = -3
107+
108+
EVOL(1) = 0.50
109+
EVOL(2) = 0.80
110+
EVOL(3) = 0.0
111+
EVOL(4) = 0.05
112+
EVOL(5) = 0.
113+
EVOL(6) = 1.
114+
C Busy loop
115+
TIMOUT=60.0
116+
C create 5 sliders
117+
DO I=1, NSLID
118+
CALL PSVLM(WKID, VLDNR+I-1, PREQU, PECHO)
119+
CALL PINVL3(WKID, VLDNR+I-1, DEFAULT, PET, EVOL, LDR, DATREC)
120+
CALL PSVLM(WKID, VLDNR+I-1, PEVENT, PECHO)
121+
ENDDO
122+
I=0
123+
DO I=1, NSLID
124+
CALL PSVLM(WKID, VLDNR+I-1, PREQU, PECHO)
125+
CALL PINVL3(WKID, VLDNR+I-1, DEFAULT, PET, EVOL, LDR, DATREC)
126+
CALL PSVLM(WKID, VLDNR+I-1, PEVENT, PECHO)
127+
ENDDO
128+
129+
DO WHILE (1 .GT. 0)
130+
CALL PWAIT(TIMOUT, WKIDI, ICL, IDEV )
131+
IF (ICL.EQ.PVALUA) THEN
132+
CALL PFLUSH(WKID, ICL, IDEV)
133+
IDEV=MOD(IDEV, 10)
134+
CALL PGTVL (VALUE)
135+
print*, "Device ",IDEV,"Value:", VALUE
136+
DEFAULT=VALUE
137+
ENDIF
138+
ENDDO
139+
140+
CALL PCLWK(WKID)
141+
142+
C Close PHIGS
143+
CALL PCLPH
144+
145+
STOP
146+
END

‎src/test_f/test_f11.f‎

Lines changed: 211 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,211 @@
1+
C *****************************************************************************
2+
C * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS HEADER
3+
C *
4+
C * This file is part of Open PHIGS
5+
C * Copyright (C) 2022-2023 CERN
6+
C *
7+
C * Open PHIGS is free software: you can redistribute it and/or modify
8+
C * it under the terms of the GNU Lesser General Public License as published by
9+
C * the Free Software Foundation, either version 2.1 of the License, or
10+
C * (at your option) any later version.
11+
C *
12+
C * Open PHIGS is distributed in the hope that it will be useful,
13+
C * but WITHOUT ANY WARRANTY; without even the implied warranty of
14+
C * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15+
C * GNU Lesser General Public License for more details.
16+
C *
17+
C * You should have received a copy of the GNU Lesser General Public License
18+
C * along with Open PHIGS. If not, see <http://www.gnu.org/licenses/>.
19+
C *****************************************************************************
20+
SUBROUTINE INITCH(WKID)
21+
IMPLICIT NONE
22+
C Include PHIGS enumeration file
23+
INCLUDE 'phigsf77.h'
24+
INTEGER N, MAXSTR
25+
PARAMETER(N=5, MAXSTR=30)
26+
CHARACTER(LEN=MAXSTR) STRING(N+1)
27+
CHARACTER(LEN=80) DATREC(MAXSTR)
28+
INTEGER PROMPT(N),LSTR(N+1)
29+
INTEGER WKID, I, ISTAT
30+
INTEGER CHDNR, ICHNR, MLDR, IERR, LDR, PET
31+
REAL EVOL(6)
32+
REAL EMPTY(1)
33+
DATA EMPTY/0.0/
34+
DATA STRING/'EXIT','VAL ON/OFF',
35+
+ 'CHOICE3','CHOICE4','CHOICE5', 'Please choose an option'/
36+
PET = -4
37+
EVOL(1) = 0.50
38+
EVOL(2) = 0.80
39+
EVOL(3) = 0.0
40+
EVOL(4) = 0.05
41+
EVOL(5) = 0.
42+
EVOL(6) = 1.
43+
44+
CHDNR = 1
45+
ICHNR = 0
46+
MLDR = MAXSTR
47+
C Init prompts and actual string length
48+
DO 3 I = 1,N
49+
PROMPT(I) = PON
50+
LSTR(I) = LEN(STRING(I))
51+
3 CONTINUE
52+
LSTR(N+1) = LEN(STRING(N+1))
53+
54+
CALL PPREC(4, PROMPT, 0, EMPTY, N+1, LSTR, STRING, MLDR,
55+
+ IERR, LDR, DATREC)
56+
CALL PSCHM(WKID, CHDNR, PREQU, PECHO)
57+
CALL PINCH3(WKID, CHDNR, ISTAT, ICHNR, PET, EVOL, LDR, DATREC)
58+
END
59+
60+
SUBROUTINE INITVAL(WKID)
61+
IMPLICIT NONE
62+
C Include PHIGS enumeration file
63+
INCLUDE 'phigsf77.h'
64+
INTEGER WKID, I, NSLID(1), IERR, LDR, PET
65+
INTEGER LSTR(4)
66+
CHARACTER*20 config(4)
67+
DATA CONFIG /"Input:", "%8.3g", "min", "max"/
68+
REAL EVOL(6), RA(2), DEFAULT, VALUE
69+
INTEGER MLDR, VLDNR
70+
CHARACTER(LEN=80) DATREC(10)
71+
PARAMETER(MLDR=20)
72+
73+
C Init the string lengths
74+
DO I=1, 4
75+
LSTR(I) = LEN(CONFIG(I))
76+
ENDDO
77+
C scale from .. to
78+
RA(1) = 0.
79+
RA(2) = 100.
80+
C create 5 sliders
81+
NSLID(1) = 5
82+
CALL PPREC(1, NSLID(1), 2, RA, 4, LSTR, CONFIG,
83+
+ MLDR, IERR, LDR, DATREC)
84+
85+
C for echo type -1: as for 1 but we can specify the strings
86+
PET = -3
87+
88+
EVOL(1) = 0.50
89+
EVOL(2) = 0.80
90+
EVOL(3) = 0.0
91+
EVOL(4) = 0.05
92+
EVOL(5) = 0.
93+
EVOL(6) = 1.
94+
95+
96+
C create 5 sliders
97+
VLDNR = 1
98+
DO I=1, NSLID(1)
99+
CALL PSVLM(WKID, VLDNR+I-1, PREQU, PECHO)
100+
CALL PINVL3(WKID, VLDNR+I-1, DEFAULT, PET, EVOL, LDR, DATREC)
101+
CALL PSVLM(WKID, VLDNR+I-1, PEVENT, PECHO)
102+
ENDDO
103+
104+
END
105+
106+
PROGRAM COMBINED
107+
IMPLICIT NONE
108+
109+
C Include PHIGS enumeration file
110+
INCLUDE 'phigsf77.h'
111+
112+
C Delcare variables
113+
INTEGER I, WKID, IERR, ISTAT, CHDNR
114+
INTEGER WKIDI, ICL, ICH, IDEV
115+
INTEGER LSTR(4)
116+
LOGICAL SLIDER
117+
DATA SLIDER/.FALSE./
118+
REAL DEFAULT, VALUE
119+
REAL TIMOUT
120+
C Delcare arrays
121+
REAL COLR(1:3)
122+
123+
C Set some parameters
124+
C Workstation ID
125+
WKID=1
126+
C Initial value
127+
DEFAULT = 30.
128+
C First Device ID
129+
CHDNR = 1
130+
C Time out in seconds
131+
TIMOUT = 60.
132+
C Open PHIGS and a workstation
133+
CALL POPPH(0, 1)
134+
CALL POPWK(WKID, 0, 3)
135+
C Define colour in workstation table
136+
COLR(1) = 1.0
137+
COLR(2) = 0.0
138+
COLR(3) = 0.0
139+
CALL PSCR(WKID, 1, 3, COLR)
140+
141+
C Open structure
142+
CALL POPST(0)
143+
144+
C Set background color to white
145+
COLR(1) = 1.0
146+
COLR(2) = 1.0
147+
COLR(3) = 1.0
148+
CALL PSCR(WKID, 0, 3, COLR)
149+
150+
C Set text attributes
151+
CALL PSCHH(0.04)
152+
153+
C Draw text
154+
CALL PSTXCI(1)
155+
CALL PTX(0.22, 0.48, 'Combined test')
156+
157+
C Close structure
158+
CALL PCLST
159+
160+
C Post structure to workstation
161+
CALL PPOST(WKID, 0, 0.0)
162+
C init choices
163+
CALL INITCH(WKID)
164+
C Wait for events
165+
DO WHILE (1 .GT. 0)
166+
CALL PSCHM(WKID, CHDNR, PEVENT, PECHO)
167+
CALL PWAIT(TIMOUT, WKIDI, ICL, IDEV )
168+
C Check for Choice events
169+
IF (ICL.EQ.PCHOIC) THEN
170+
CALL PFLUSH(WKID, ICL, IDEV)
171+
CALL PGTCH(ISTAT,ICH)
172+
IF (ISTAT.EQ.POK) THEN
173+
IF (ICH.EQ.2) THEN
174+
IF (.NOT.SLIDER) THEN
175+
SLIDER=.TRUE.
176+
C init valuators
177+
CALL INITVAL(WKID)
178+
ELSE
179+
SLIDER=.FALSE.
180+
DO 70 I=1,5
181+
CALL PSVLM(WKID,I,PREQU,PECHO)
182+
70 CONTINUE
183+
END IF
184+
ELSE
185+
IF (ICH.EQ.1) THEN
186+
GOTO 222
187+
ENDIF
188+
print*, "Other choice event ", ICH
189+
ENDIF
190+
ELSE
191+
PRINT*, "Choice event status NOT OK"
192+
ENDIF
193+
194+
ENDIF
195+
C check for valuator events
196+
IF (ICL.EQ.PVALUA) THEN
197+
CALL PFLUSH(WKID, ICL, IDEV)
198+
IDEV=MOD(IDEV, 10)
199+
CALL PGTVL (VALUE)
200+
print*, "Device ",IDEV,"Value:", VALUE
201+
DEFAULT=VALUE
202+
ENDIF
203+
ENDDO
204+
222 CONTINUE
205+
CALL PCLWK(WKID)
206+
207+
C Close PHIGS
208+
CALL PCLPH
209+
210+
STOP
211+
END

0 commit comments

Comments
 (0)