Skip to content

Commit

Permalink
remove dynamic allocation: fixes issue #623
Browse files Browse the repository at this point in the history
Vegan could not be built for webR/wasm because their Fortran
compiler (under development) did not handle dynamic allocation.

This needed some hand-editing as the fix was not based on the
latest github version and contained removed subroutines.
  • Loading branch information
prminchin authored and jarioksa committed Mar 11, 2024
1 parent 65dce8d commit 75e347d
Showing 1 changed file with 21 additions and 11 deletions.
32 changes: 21 additions & 11 deletions src/monoMDS.f
Original file line number Diff line number Diff line change
Expand Up @@ -14,6 +14,11 @@ SUBROUTINE monoMDS (NOBJ, NFIX, NDIM, NDIS, NGRP,
C dissimilarities are correctly handled in
C creating the initial partition for monotone
C regression with primary tie treatment.
C 1.03 April 11, 2023 - changed calculation of M in ASORT4 from
C exponentiation to use of ISHIFT to avoid a
C problem with some optimizing compilers
C 1.04 March 8, 2024 - removed the use of ALLOCATABLE arrays by making
C IWORK, GRAD, and GRLAST permananet local arrays
C
C Written by Dr. Peter R. Minchin
C Department of Biological Sciences
Expand Down Expand Up @@ -137,18 +142,19 @@ SUBROUTINE monoMDS (NOBJ, NFIX, NDIM, NDIS, NGRP,
INTEGER, INTENT(OUT) :: ITERS, ICAUSE
DOUBLE PRECISION, INTENT(OUT) :: X(NOBJ,NDIM), DIST(NDIS),
. DHAT(NDIS), STRESS, STRS(NGRP)
C---ALLOCATABLE TEMPORARY ARRAYS
INTEGER, ALLOCATABLE :: IWORK(:)
DOUBLE PRECISION, ALLOCATABLE :: GRAD(:,:), GRLAST(:,:)
C-Removed the use of allocatable arrays (v 1.04)
C---TEMPORARY ARRAYS
INTEGER :: IWORK(NDIS)
DOUBLE PRECISION :: GRAD(NOBJ,NDIM), GRLAST(NOBJ,NDIM)
C
DOUBLE PRECISION :: STRLST, SQRTN, SRATF1, SRATF2, FNGRP,
. STRINC, COSAV, ACOSAV, SRATAV, STEP, FNDIM, SFGR, SRATIO,
. SFACT, TFACT, DMEAN, CAGRGL, SFGLST, STPNEW, SSFACB, SSFACT,
. PARAM(2)
C
C-Removed the use of allocatable arrays (v 1.04)
C ALLOCATE THE TEMPORARY ARRAYS NEEDED
C
ALLOCATE (IWORK(NDIS), GRAD(NOBJ,NDIM), GRLAST(NOBJ,NDIM))
C
C ALLOCATE (IWORK(NDIS), GRAD(NOBJ,NDIM), GRLAST(NOBJ,NDIM))
C
C INITIALIZE SOME PARAMETERS
C
Expand Down Expand Up @@ -354,9 +360,10 @@ SUBROUTINE monoMDS (NOBJ, NFIX, NDIM, NDIS, NGRP,
C
C=======================================================================
C
C-Removed the use of allocatable arrays (v 1.04)
C DEALLOCATE THE TEMPORARY ARRAYS AND RETURN
C
DEALLOCATE (IWORK, GRAD, GRLAST)
C DEALLOCATE (IWORK, GRAD, GRLAST)
RETURN
END SUBROUTINE monoMDS

Expand All @@ -382,7 +389,10 @@ SUBROUTINE ASORT4 (X,N,I1,I2)
IF (N.LT.2) RETURN
FN=REAL(N)
NLOOPS=MAX(NINT(LOG(FN)/LOG(2.)),1)
M=ISHFT(1,NLOOPS-1) ! i.e., 2^(N_LOOPS-1) using bit shifts
C REPLACED EXPONENTIATION BY ISHFT TO AVOID A PROBLEM WITH SOME
C OPTIMIZING COMPILERS (v 1.03)
C M=2**(NLOOPS-1)
M=ISHFT(1, NLOOPS-1)
DO II=1,NLOOPS
FM=M
DO I=1,MAX(1,N-M)
Expand Down Expand Up @@ -600,9 +610,9 @@ SUBROUTINE CLCSTP (STEP,IT,SFGR,STRESS,COSAV,ACOSAV,SRATIO,
C
ELSE
FACTR1=4.0**COSAV
FACTR2=1.6/( (1.0+(MIN(1D0,SRATAV))**5) *
FACTR2=1.6/( (1.0+(MIN(1.0,SRATAV))**5) *
. (1.0+ACOSAV-ABS(COSAV)) )
FACTR3=SQRT(MIN(1D0,SRATIO))
FACTR3=SQRT(MIN(1.0,SRATIO))
STEP=STEP*FACTR1*FACTR2*FACTR3
ENDIF
RETURN
Expand Down Expand Up @@ -761,7 +771,7 @@ SUBROUTINE MAMAS (A,MAXL,L,M,S)
ENDDO
RETURN
END SUBROUTINE MAMAS

SUBROUTINE MONREG (DISS,DIST,DHAT,IIDX,JIDX,IWORK,N,ITIES)
C
C PERFORMS KRUSKAL'S MONOTONE REGRESSION OF DIST ON DISS, PLACING THE
Expand Down

0 comments on commit 75e347d

Please sign in to comment.