First commit of all DC FORTRAN source code.

Author: remislp

Fort90/AFIXR.FOR

@@ -0,0 +1,7 @@
+	function AFIXR(x)
+c To round a real value correctly (like ifixr but result real)
+	x1=x+sign(0.5,x)
+	afixr=x1-amod(x1,1.)
+	return
+	end
+

Fort90/ALPHA.FOR

@@ -0,0 +1,17 @@
+	program ALPHA
+c To reset screen to alpha mode (eg after crash of program while
+c in graphics)
+c	call VIDEOMOD(3)		!utility lib- this makes graph go for good!
+c For Toshiba VIDEOTYP()=18 for graphics mode, =3 for alpha mode
+	integer*2 i1,i2,videotyp
+c
+	i1=videotyp()
+c	if(videotyp().eq.18) call VIDEOMOD(3)
+	call VIDEOMOD(3)
+	i2=videotyp()
+	print 1,i1,i2
+1	format(' video mode changed from ',i3,' to ',i3)
+c
+	end
+
+

Fort90/ARLY.FOR

@@ -0,0 +1,61 @@
+	program arly
+	real a(10)
+	n=10
+	a(1)=1.1
+	a(2)=1.
+	a(3)=1.1
+	a(4)=2.3
+	a(5)=2.3
+	a(6)=3.
+	a(7)=3.
+	a(8)=-1.
+	a(9)=1.
+	a(10)=1.1
+	i=1
+	m=n
+	do while(i.le.m)
+	   k=i+1
+	   do while(k.le.m)
+	      if(a(i).eq.a(k)) then
+		   do while(a(k).eq.a(m).and.m.gt.k)
+			m=m-1
+		   enddo
+		   t=a(k)
+		   a(k)=a(m)
+		   a(m)=t
+		   m=m-1
+		endif
+		k=k+1
+	   enddo
+	   i=i+1
+	enddo
+	print*,'result:',m
+	do j=1,m
+	   print*,a(j)
+	enddo
+	print*,'z='
+	read*,z
+	k=0
+	if(abs(z).gt.1.) then
+	   y=abs(z)
+	   do while(y.gt.1)
+		y=y/10.
+		k=k+1
+	   enddo
+	   a1=y*10.
+	   if (z.lt.0.) a1=-y*10.
+	   b1= k-1
+	   goto 1
+	else if(abs(z).gt.0.and.abs(z).lt.1) then
+	   y=abs(z)
+	   do while(y.lt.1)
+		y=y*10.
+		k=k+1
+	   enddo
+	   a1=y
+	   if (z.lt.0.) a1=-y
+	   b1=-k
+	   goto 1
+	endif
+1	print*,a1,' ',b1
+	end

Fort90/ARMOV.FOR

@@ -0,0 +1,34 @@
+	program armov
+	integer a(10)
+	n=10
+	a(1)=2
+	a(2)=2
+	a(3)=3
+	a(4)=3
+	a(5)=7
+	a(6)=3
+	a(7)=4
+	a(8)=4
+	a(9)=1
+	a(10)=1
+	j=1
+	do i=1,n-1
+	   do k=i+1,n
+	      if(a(i).eq.a(k)) a(i)=-100
+	   enddo
+	enddo
+	do i=1,n
+	   print*,a(i)
+	enddo
+	do i=1,n
+	   if(a(i).ne.-100) then
+		a(j)=a(i)
+		j=j+1
+	   endif
+	enddo
+	m=j-1
+	print*,'result:'
+	do j=1,m
+	   print*,a(j)
+	enddo
+	end

Fort90/ARMOV1.FOR

@@ -0,0 +1,28 @@
+	program armov1
+	integer a(10)
+	n=10
+	a(1)=1
+	a(2)=1
+	a(3)=1
+	a(4)=2
+	a(5)=2
+	a(6)=3
+	a(7)=3
+	a(8)=1
+	a(9)=1
+	a(10)=1
+	j=1
+	do i=1,n
+	   do k=i,n
+	      if((k.ne.i).and.(a(i).eq.a(k))) a(k)=-100
+	   enddo
+	   if(a(i).ne.-100) then
+		a(j)=a(i)
+		j=j+1
+	   endif
+	enddo
+	m=j-1
+	do j=1,m
+	   print*,a(j)
+	enddo
+	end

Fort90/ARMY.FOR

@@ -0,0 +1,29 @@
+	program army
+	real a(10)
+	n=10
+	a(1)=2.1
+	a(2)=2.2
+	a(3)=3.3
+	a(4)=3.3
+	a(5)=7.
+	a(6)=3.3
+	a(7)=4.
+	a(8)=4.
+	a(9)=1.
+	a(10)=8.
+	j=1
+	do i=1,n-1
+	   do k=i+1,n
+	      if(a(i).eq.a(k)) a(i)=-100
+	   enddo
+	   if(a(i).ne.-100) then
+		a(j)=a(i)
+		j=j+1
+	   endif
+	enddo
+	m=j-1
+	print*,'result:'
+	do j=1,m
+	   print*,a(j)
+	enddo
+	end

Fort90/ARRAYD.FOR

@@ -0,0 +1,96 @@
+      SUBROUTINE ARRAYD(MODE,I,J,N,M,S,D)
+c      dimension S(100),D(100)
+c      dimension S(400),D(400)
+      dimension S(n*m),D(n*m)
+      DOUBLE PRECISION S,D
+C#### MODIF 02/20/90 04:17pm for 20x20 arrays
+C     ..................................................................
+C
+C        SUBROUTINE ARRAYD
+C ***dimension DOUBLE PRECISION S AND D ARGUMENTS- CAN BE THE SAME
+C        PURPOSE
+C           CONVERT DATA ARRAY FROM SINGLE TO DOUBLE DIMENSION OR VICE
+C           VERSA.  THIS SUBROUTINE IS USED TO LINK THE USER PROGRAM
+C           WHICH HAS DOUBLE DIMENSION ARRAYS AND THE SSP SUBROUTINES
+C           WHICH OPERATE ON ARRAYS OF DATA IN A VECTOR FASHION.
+C
+C        USAGE
+C           CALL ARRAYD(MODE,I,J,N,M,S,D)
+C
+C        DESCRIPTION OF PARAMETERS
+C           MODE - CODE INDICATING TYPE OF CONVERSION
+C                    1 - FROM SINGLE TO DOUBLE DIMENSION
+C                    2 - FROM DOUBLE TO SINGLE DIMENSION
+C           I    - NUMBER OF ROWS IN ACTUAL DATA MATRIX
+C           J    - NUMBER OF COLUMNS IN ACTUAL DATA MATRIX
+C           N    - NUMBER OF ROWS SPECIFIED FOR THE MATRIX D IN
+C                  DIMENSION STATEMENT
+C           M    - NUMBER OF COLUMNS SPECIFIED FOR THE MATRIX D IN
+C                  DIMENSION STATEMENT
+C           S    - IF MODE=1, THIS VECTOR IS INPUT WHICH CONTAINS THE
+C                  ELEMENTS OF A DATA MATRIX OF SIZE I BY J. COLUMN I+1
+C                  OF DATA MATRIX FOLLOWS COLUMN I, ETC. IF MODE=2,
+C                  THIS VECTOR IS OUTPUT REPRESENTING A DATA MATRIX OF
+C                  SIZE I BY J CONTAINING ITS COLUMNS CONSECUTIVELY.
+C                  THE LENGTH OF S IS IJ, WHERE IJ=I*J.
+C           D    - IF MODE=1, THIS MATRIX OF SIZE N BY M IS OUTPUT,
+C                  CONTAINING A DATA MATRIX OF SIZE I BY J IN THE FIRST
+C                  I ROWS AND J COLUMNS. IF MODE=2, THIS N BY M MATRIX
+C                  IS INPUT CONTAINING A DATA MATRIX OF SIZE I BY J IN
+C                  THE FIRST I ROWS AND J COLUMNS.
+C
+C        REMARKS
+C           VECTOR S CAN BE IN THE SAME LOCATION AS MATRIX D.  VECTOR S
+C           IS REFERRED AS A MATRIX IN OTHER SSP ROUTINES, SINCE IT
+C           CONTAINS A DATA MATRIX.
+C           THIS SUBROUTINE CONVERTS ONLY GENERAL DATA MATRICES (STORAGE
+C           MODE OF 0).
+C
+C        SUBROUTINES AND FUNCTION SUBROUTINES REQUIRED
+C           NONE
+C
+C        METHOD
+C           REFER TO THE DISCUSSION ON VARIABLE DATA SIZE IN THE SECTION
+C           DESCRIBING OVERALL RULES FOR USAGE IN THIS MANUAL.
+C
+C     ..................................................................
+C
+C
+c	do 500 k=1,25
+c500	print *,k,d(k)
+C
+      NI=N-I
+C
+C        TEST TYPE OF CONVERSION
+C
+      IF(MODE-1) 100, 100, 120
+C
+C        CONVERT FROM SINGLE TO DOUBLE DIMENSION
+C
+  100 IJ=I*J+1
+      NM=N*J+1
+      DO 110 K=1,J
+      NM=NM-NI
+      DO 110 L=1,I
+      IJ=IJ-1
+      NM=NM-1
+  110 D(NM)=S(IJ)
+      GO TO 140
+C
+C        CONVERT FROM DOUBLE TO SINGLE DIMENSION
+C
+  120 IJ=0
+      NM=0
+      DO 130 K=1,J
+      DO 125 L=1,I
+      IJ=IJ+1
+      NM=NM+1
+  125 S(IJ)=D(NM)
+  130 NM=NM+NI
+C
+140	continue
+c	do 501 k=1,25
+c501	print *,k,s(k)
+c
+	RETURN
+      END