You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
554 lines
15 KiB
554 lines
15 KiB
C Copyright(C) 1999-2020 National Technology & Engineering Solutions
|
|
C of Sandia, LLC (NTESS). Under the terms of Contract DE-NA0003525 with
|
|
C NTESS, the U.S. Government retains certain rights in this software.
|
|
C
|
|
C See packages/seacas/LICENSE for details
|
|
|
|
subroutine cgidum
|
|
end
|
|
|
|
#ifdef Build64
|
|
|
|
c This wrapper module handles two kinds of interface problems:
|
|
c the routines starting with 'v' arbitrate between Fortran caller
|
|
c and C callee; the routines; starting with 'c' arbitrate between
|
|
c C caller and Fortran callee. The only exception is cgtxx1,
|
|
c which arbitrates between Fortran caller and C callee.
|
|
|
|
subroutine vdinit (aspect,justif)
|
|
real*8 aspect
|
|
integer*8 justif
|
|
real*4 aspect4
|
|
integer*4 justif4
|
|
aspect4 = aspect
|
|
justif4 = justif
|
|
call vdinit4 (aspect4,justif4)
|
|
c aspect = aspect4
|
|
c justif = justif4
|
|
end
|
|
c-----------------------------------------------------------------------
|
|
subroutine vdiqdc (indexa,value)
|
|
integer*8 indexa
|
|
real*8 value
|
|
integer*4 indexa4
|
|
real*4 value4
|
|
indexa4 = indexa
|
|
C ... 'value' is writeonly,
|
|
call vdiqdc4 (indexa4,value4)
|
|
indexa = indexa4
|
|
value = value4
|
|
end
|
|
c-----------------------------------------------------------------------
|
|
subroutine vdstco (num,index_array,color_array,color_mod)
|
|
integer*8 num
|
|
integer*8 index_array(num)
|
|
real*8 color_array(3,num)
|
|
integer*8 color_mod
|
|
integer*4 num4
|
|
integer*4 index_array4(num)
|
|
real*4 color_array4(3,num)
|
|
integer*4 color_mod4
|
|
INTEGER J1X, J2X
|
|
num4 = num
|
|
DO J1X = 1, NUM
|
|
INDEX_ARRAY4(J1X) = INDEX_ARRAY(J1X)
|
|
END DO
|
|
DO J2X = 1, 3*NUM
|
|
COLOR_ARRAY4(J2X,1) = COLOR_ARRAY(J2X,1)
|
|
END DO
|
|
color_mod4 = color_mod
|
|
call vdstco4 (num4,index_array4,color_array4,color_mod4)
|
|
c num = num4
|
|
c DO J1X = 1, NUM
|
|
c INDEX_ARRAY(J1X) = INDEX_ARRAY4(J1X)
|
|
c END DO
|
|
c DO J2X = 1, 3*NUM
|
|
c COLOR_ARRAY(J2X,1) = COLOR_ARRAY4(J2X,1)
|
|
c END DO
|
|
c color_mod = color_mod4
|
|
end
|
|
c-----------------------------------------------------------------------
|
|
subroutine vdiqco (num,index_array,color_array,color_mod)
|
|
integer*8 num
|
|
integer*8 index_array(num)
|
|
real*8 color_array(3,num)
|
|
integer*8 color_mod
|
|
integer*4 num4
|
|
integer*4 index_array4(num)
|
|
real*4 color_array4(3,num)
|
|
integer*4 color_mod4
|
|
INTEGER J1X, J2X
|
|
num4 = num
|
|
DO J1X = 1, NUM
|
|
INDEX_ARRAY4(J1X) = INDEX_ARRAY(J1X)
|
|
END DO
|
|
C ... 'color_array' is writeonly.
|
|
color_mod4 = color_mod
|
|
call vdiqco4 (num4,index_array4,color_array4,color_mod4)
|
|
c num = num4
|
|
c DO J1X = 1, NUM
|
|
c INDEX_ARRAY(J1X) = INDEX_ARRAY4(J1X)
|
|
c END DO
|
|
DO J2X = 1, 3*NUM
|
|
COLOR_ARRAY(J2X,1) = COLOR_ARRAY4(J2X,1)
|
|
END DO
|
|
c color_mod = color_mod4
|
|
end
|
|
c-----------------------------------------------------------------------
|
|
subroutine vdescp (escape_code,n,args)
|
|
integer*8 escape_code
|
|
integer*8 n
|
|
real*8 args(n)
|
|
integer*4 escape_code4
|
|
integer*4 n4
|
|
real*4 args4(n)
|
|
INTEGER J1X
|
|
escape_code4 = escape_code
|
|
n4 = n
|
|
DO J1X = 1, N
|
|
ARGS4(J1X) = ARGS(J1X)
|
|
END DO
|
|
call vdescp4 (escape_code4,n4,args4)
|
|
c escape_code = escape_code4
|
|
c n = n4
|
|
DO J1X = 1, N
|
|
ARGS(J1X) = ARGS4(J1X)
|
|
END DO
|
|
end
|
|
c-----------------------------------------------------------------------
|
|
subroutine vdiqes (escape_code,support)
|
|
integer*8 escape_code
|
|
integer*8 support
|
|
integer*4 escape_code4
|
|
integer*4 support4
|
|
C... escape_code unused, support is write only.
|
|
call vdiqes4 (escape_code4,support4)
|
|
support = support4
|
|
end
|
|
c-----------------------------------------------------------------------
|
|
subroutine vdiqnd (x_ndc,y_ndc)
|
|
real*8 x_ndc
|
|
real*8 y_ndc
|
|
real*4 x_ndc4
|
|
real*4 y_ndc4
|
|
C ... x_ndc, y_ndc write-only arguments
|
|
call vdiqnd4 (x_ndc4,y_ndc4)
|
|
x_ndc = x_ndc4
|
|
y_ndc = y_ndc4
|
|
end
|
|
c-----------------------------------------------------------------------
|
|
subroutine vdmova (x,y)
|
|
real*8 x
|
|
real*8 y
|
|
real*4 x4
|
|
real*4 y4
|
|
x4 = x
|
|
y4 = y
|
|
call vdmova4 (x4,y4)
|
|
x = x4
|
|
y = y4
|
|
end
|
|
c-----------------------------------------------------------------------
|
|
subroutine vdlina (x,y)
|
|
real*8 x
|
|
real*8 y
|
|
real*4 x4
|
|
real*4 y4
|
|
x4 = x
|
|
y4 = y
|
|
call vdlina4 (x4,y4)
|
|
x = x4
|
|
y = y4
|
|
end
|
|
c-----------------------------------------------------------------------
|
|
subroutine vdpnta (x,y)
|
|
real*8 x
|
|
real*8 y
|
|
real*4 x4
|
|
real*4 y4
|
|
x4 = x
|
|
y4 = y
|
|
call vdpnta4 (x4,y4)
|
|
x = x4
|
|
y = y4
|
|
end
|
|
c-----------------------------------------------------------------------
|
|
subroutine vdtext (length,char_array)
|
|
integer*8 length
|
|
integer*8 char_array(length)
|
|
integer*4 length4
|
|
integer*4 char_array4(length)
|
|
INTEGER J1X
|
|
length4 = length
|
|
DO J1X = 1, LENGTH
|
|
CHAR_ARRAY4(J1X) = CHAR_ARRAY(J1X)
|
|
END DO
|
|
call vdtext4 (length4,char_array4)
|
|
length = length4
|
|
DO J1X = 1, LENGTH
|
|
CHAR_ARRAY(J1X) = CHAR_ARRAY4(J1X)
|
|
END DO
|
|
end
|
|
c-----------------------------------------------------------------------
|
|
subroutine vdpoly (x_array,y_array,npts)
|
|
integer*8 npts
|
|
real*8 x_array(npts)
|
|
real*8 y_array(npts)
|
|
real*4 x_array4(npts)
|
|
real*4 y_array4(npts)
|
|
integer*4 npts4
|
|
INTEGER J1X
|
|
DO J1X = 1, NPTS
|
|
X_ARRAY4(J1X) = X_ARRAY(J1X)
|
|
Y_ARRAY4(J1X) = Y_ARRAY(J1X)
|
|
END DO
|
|
npts4 = npts
|
|
call vdpoly4 (x_array4,y_array4,npts4)
|
|
DO J1X = 1, NPTS
|
|
X_ARRAY(J1X) = X_ARRAY4(J1X)
|
|
Y_ARRAY(J1X) = Y_ARRAY4(J1X)
|
|
END DO
|
|
npts = npts4
|
|
end
|
|
c-----------------------------------------------------------------------
|
|
subroutine vdiqcp (x,y)
|
|
real*8 x
|
|
real*8 y
|
|
real*4 x4
|
|
real*4 y4
|
|
C... 'x' and 'y' are write-only arguments
|
|
call vdiqcp4 (x4,y4)
|
|
x = x4
|
|
y = y4
|
|
end
|
|
c-----------------------------------------------------------------------
|
|
subroutine vdiqos (attr_array)
|
|
real*8 attr_array(7)
|
|
real*4 attr_array4(7)
|
|
INTEGER J1X
|
|
C ... attr_array4 argument is write only, don't initialize
|
|
call vdiqos4 (attr_array4)
|
|
DO J1X = 1, 7
|
|
ATTR_ARRAY(J1X) = ATTR_ARRAY4(J1X)
|
|
END DO
|
|
end
|
|
c-----------------------------------------------------------------------
|
|
subroutine vdstfc (color_index)
|
|
integer*8 color_index
|
|
integer*4 color_index4
|
|
color_index4 = color_index
|
|
call vdstfc4 (color_index4)
|
|
c color_index = color_index4
|
|
end
|
|
c-----------------------------------------------------------------------
|
|
subroutine vdstbc (color_index)
|
|
integer*8 color_index
|
|
integer*4 color_index4
|
|
color_index4 = color_index
|
|
call vdstbc4 (color_index4)
|
|
c color_index = color_index4
|
|
end
|
|
c-----------------------------------------------------------------------
|
|
subroutine vdstin (intensity)
|
|
real*8 intensity
|
|
real*4 intensity4
|
|
intensity4 = intensity
|
|
call vdstin4 (intensity4)
|
|
c intensity = intensity4
|
|
end
|
|
c-----------------------------------------------------------------------
|
|
subroutine vdstls (line_style)
|
|
integer*8 line_style
|
|
integer*4 line_style4
|
|
line_style4 = line_style
|
|
call vdstls4 (line_style4)
|
|
c line_style = line_style4
|
|
end
|
|
c-----------------------------------------------------------------------
|
|
subroutine vdstlw (line_width)
|
|
real*8 line_width
|
|
real*4 line_width4
|
|
line_width4 = line_width
|
|
call vdstlw4 (line_width4)
|
|
c line_width = line_width4
|
|
end
|
|
c-----------------------------------------------------------------------
|
|
subroutine vdstcs (y_size)
|
|
real*8 y_size
|
|
real*4 y_size4
|
|
y_size4 = y_size
|
|
call vdstcs4 (y_size4)
|
|
c y_size = y_size4
|
|
end
|
|
c-----------------------------------------------------------------------
|
|
subroutine vdaabu (button)
|
|
integer*8 button
|
|
integer*4 button4
|
|
C ... 'button' is write-only argument
|
|
call vdaabu4 (button4)
|
|
button = button4
|
|
end
|
|
c-----------------------------------------------------------------------
|
|
subroutine vdaloc (x,y)
|
|
real*8 x
|
|
real*8 y
|
|
real*4 x4
|
|
real*4 y4
|
|
C ... 'x' and 'y' are write-only arguments
|
|
call vdaloc4 (x4,y4)
|
|
x = x4
|
|
y = y4
|
|
end
|
|
c-----------------------------------------------------------------------
|
|
subroutine vdabgl (button,x,y)
|
|
integer*8 button
|
|
real*8 x
|
|
real*8 y
|
|
integer*4 button4
|
|
real*4 x4
|
|
real*4 y4
|
|
C... 'button', 'x', and 'y' are write-only
|
|
call vdabgl4 (button4,x4,y4)
|
|
button = button4
|
|
x = x4
|
|
y = y4
|
|
end
|
|
c-----------------------------------------------------------------------
|
|
subroutine vdakgl (charac,x,y)
|
|
integer*8 charac
|
|
real*8 x
|
|
real*8 y
|
|
integer*4 charac4
|
|
real*4 x4
|
|
real*4 y4
|
|
C ... arguments are write-only
|
|
charac4 = 0
|
|
x4 = 0.0
|
|
y4 = 0.0
|
|
call vdakgl4 (charac4,x4,y4)
|
|
charac = charac4
|
|
x = x4
|
|
y = y4
|
|
end
|
|
c-----------------------------------------------------------------------
|
|
subroutine vdstla (x,y)
|
|
real*8 x
|
|
real*8 y
|
|
real*4 x4
|
|
real*4 y4
|
|
C ... arguments are write-only
|
|
x4 = 0.0
|
|
y4 = 0.0
|
|
call vdstla4 (x4,y4)
|
|
x = x4
|
|
y = y4
|
|
end
|
|
c-----------------------------------------------------------------------
|
|
subroutine vdstos (attr_array)
|
|
real*8 attr_array(6)
|
|
real*4 attr_array4(6)
|
|
INTEGER J1X
|
|
DO J1X = 1, 6
|
|
ATTR_ARRAY4(J1X) = ATTR_ARRAY(J1X)
|
|
END DO
|
|
call vdstos4 (attr_array4)
|
|
DO J1X = 1, 6
|
|
ATTR_ARRAY(J1X) = ATTR_ARRAY4(J1X)
|
|
END DO
|
|
end
|
|
c-----------------------------------------------------------------------
|
|
subroutine vdfram (itype)
|
|
integer*8 itype
|
|
integer*4 itype4
|
|
itype4 = itype
|
|
call vdfram4 (itype4)
|
|
c itype = itype4
|
|
end
|
|
c-----------------------------------------------------------------------
|
|
subroutine cesc24 (i1, i2, r1)
|
|
integer*4 i1, i2
|
|
real*4 r1
|
|
integer*8 l1, l2
|
|
real*8 d1
|
|
l1 = i1
|
|
l2 = i2
|
|
d1 = r1
|
|
call cesc2 (l1, l2, d1)
|
|
i1 = l1
|
|
i2 = l2
|
|
r1 = d1
|
|
end
|
|
c-----------------------------------------------------------------------
|
|
subroutine ctx24 (r1, r2, i1, i2)
|
|
integer*4 i1(150), i2
|
|
real*4 r1, r2
|
|
integer*8 l1(150), l2
|
|
real*8 d1, d2
|
|
INTEGER J1X
|
|
DO J1X = 1, 150
|
|
L1(J1X) = I1(J1X)
|
|
END DO
|
|
l2 = i2
|
|
d1 = r1
|
|
d2 = r2
|
|
call ctx2 (d1, d2, l1, l2)
|
|
DO J1X = 1, 150
|
|
I1(J1X) = L1(J1X)
|
|
END DO
|
|
i2 = l2
|
|
r1 = d1
|
|
r2 = d2
|
|
end
|
|
c-----------------------------------------------------------------------
|
|
subroutine cgtxx24 (r1, r2, i1, i2, r3, r4, r5, r6, r7,
|
|
& r8, r9, r10, r11, r12)
|
|
integer*4 i1, i2
|
|
real*4 r1, r2, r3, r4, r5, r6, r7, r8, r9, r10, r11, r12
|
|
integer*8 l1, l2
|
|
real*8 d1, d2, d3, d4, d5, d6, d7, d8, d9, d10, d11, d12
|
|
l1 = i1
|
|
l2 = i2
|
|
d1 = r1
|
|
d2 = r2
|
|
d3 = r3
|
|
d4 = r4
|
|
d5 = r5
|
|
d6 = r6
|
|
d7 = r7
|
|
d8 = r8
|
|
d9 = r9
|
|
d10 = r10
|
|
d11 = r11
|
|
d12 = r12
|
|
call cgtxx2 (d1, d2, l1, l2, d3, d4, d5, d6, d7,
|
|
& d8, d9, d10, d11, d12)
|
|
i1 = l1
|
|
i2 = l2
|
|
r1 = d1
|
|
r2 = d2
|
|
r3 = d3
|
|
r4 = d4
|
|
r5 = d5
|
|
r6 = d6
|
|
r7 = d7
|
|
r8 = d8
|
|
r9 = d9
|
|
r10 = d10
|
|
r11 = d11
|
|
r12 = d12
|
|
end
|
|
c-----------------------------------------------------------------------
|
|
subroutine cqchh24 (i1, i2, i3, i4, i5, i6, i7)
|
|
integer*4 i1, i2, i3, i4, i5, i6, i7
|
|
integer*8 l1, l2, l3, l4, l5, l6, l7
|
|
l1 = i1
|
|
l2 = i2
|
|
l3 = i3
|
|
l4 = i4
|
|
l5 = i5
|
|
l6 = i6
|
|
l7 = i7
|
|
call cqchh2 (l1, l2, l3, l4, l5, l6, l7)
|
|
c i1 = l1
|
|
c i2 = l2
|
|
c i3 = l3
|
|
i4 = l4
|
|
i5 = l5
|
|
i6 = l6
|
|
i7 = l7
|
|
end
|
|
c-----------------------------------------------------------------------
|
|
subroutine cesc1 (l1, l2, s, l3)
|
|
integer*8 l1, l2, l3
|
|
character*(*) s
|
|
integer*4 i1, i2, i3
|
|
i1 = l1
|
|
i2 = l2
|
|
i3 = l3
|
|
call cesc14 (i1, i2, s, i3)
|
|
l1 = i1
|
|
l2 = i2
|
|
l3 = i3
|
|
end
|
|
c-----------------------------------------------------------------------
|
|
subroutine ctx1 (d1, d2, l1, s, l2)
|
|
integer*8 l1, l2
|
|
real*8 d1, d2
|
|
character*(*) s
|
|
integer*4 i1, i2
|
|
real*4 r1, r2
|
|
i1 = l1
|
|
i2 = l2
|
|
r1 = d1
|
|
r2 = d2
|
|
call ctx14( r1, r2, i1, s, i2)
|
|
c l1 = i1
|
|
l2 = i2
|
|
c d1 = r1
|
|
c d2 = r2
|
|
end
|
|
c-----------------------------------------------------------------------
|
|
subroutine cgtxx1 (d1, d2, s, l1, l2, d3, d4, d5, d6, d7,
|
|
& d8, d9, d10, d11, d12)
|
|
integer*8 l1, l2
|
|
real*8 d1, d2, d3, d4, d5, d6, d7, d8, d9, d10, d11, d12
|
|
character*(*) s
|
|
integer*4 i1, i2, i3
|
|
real*4 r1, r2, r3, r4, r5, r6, r7, r8, r9, r10, r11, r12
|
|
i1 = l1
|
|
i2 = l2
|
|
r1 = d1
|
|
r2 = d2
|
|
r3 = d3
|
|
r4 = d4
|
|
r5 = d5
|
|
r6 = d6
|
|
r7 = d7
|
|
r8 = d8
|
|
r9 = d9
|
|
r10 = d10
|
|
r11 = d11
|
|
r12 = d12
|
|
i3 = len(s)
|
|
call cgtxx14 (r1, r2, s, i1, i2, r3, r4, r5, r6, r7,
|
|
& r8, r9, r10, r11, r12, i3)
|
|
l1 = i1
|
|
l2 = i2
|
|
c d1 = r1
|
|
c d2 = r2
|
|
d3 = r3
|
|
d4 = r4
|
|
d5 = r5
|
|
d6 = r6
|
|
d7 = r7
|
|
d8 = r8
|
|
d9 = r9
|
|
d10 = r10
|
|
d11 = r11
|
|
d12 = r12
|
|
end
|
|
c-----------------------------------------------------------------------
|
|
subroutine cqchh1 (s, l1, l2, l3, l4, l5, l6, l7, l8)
|
|
integer*8 l1, l2, l3, l4, l5, l6, l7, l8
|
|
character*(*) s
|
|
integer*4 i1, i2, i3, i4, i5, i6, i7, i8
|
|
i1 = l1
|
|
i2 = l2
|
|
i3 = l3
|
|
i4 = l4
|
|
i5 = l5
|
|
i6 = l6
|
|
i7 = l7
|
|
i8 = l8
|
|
call cqchh14 (s, i1, i2, i3, i4, i5, i6, i7, i8)
|
|
C l1 = i1
|
|
C l2 = i2
|
|
C l3 = i3
|
|
l4 = i4
|
|
l5 = i5
|
|
l6 = i6
|
|
l7 = i7
|
|
l8 = i8
|
|
end
|
|
c-----------------------------------------------------------------------
|
|
#endif
|
|
|