[Snark] [FORTRAN 77] a powerful computer is required --- you will need AT LEAST 700 MEGABYTES of RAM

CYRILLE LAVIGNE submissions at badcode.rocks
Sat Apr 27 17:37:16 UTC 2019


HELLO GOOD SIRS,

I have come across your great WebSite, which is very infomative. As a
scientist and expert in High Performance Computing (HPC), I realize my
valuable skills are very well suited to your April Challenge, a
straightforward application of combinatorics.

To this E-MAIL I have attached my submission, which solves the
described problem in an efficient manner. I have used the FORTRAN 77
language for performance. The added MAKEFILE can be used to compile
the submission using GFORTRAN; the code was tested on a GNU/LINUX
UNIX-style system. The parameters in the MAKEFILE have been selected
to solve the submission but a powerful computer is required --- you
will need AT LEAST 700 MEGABYTES of RAM. I hereby certify that the
code is MY OWN and that it is released under the CC0 LICENSE.

Good day to you and your families,
CYRILLE LAVIGNE
(You may use my full name.)

== License ==

I hereby certify that the code is MY OWN and that it is released under the 
CC0 LICENSE.

== Makefile ==

FC = f77
FCFLAGS = -ffixed-form -fmax-identifier-length=7 -std=legacy
FCFLAGS+= -DMXSTCK=200000000 -DMXGRPS=200 -DICST=800

LIBR: LIBR.F
	$(FC) $(FCFLAGS) -o $@ $^ $(LDFLAGS)

.PHONY: clean 

clean:
	rm -f *.o *.mod *.MOD LIBR

== LIBR.F ==

      PROGRAM MAIN
      DIMENSION IBSKT(5),
     +     ISTCK(MXSTCK),
     +     IDSCNT(5),
     +     IGRPS(5*MXGRPS)
      DATA IDSCNT /0, 5, 10, 20, 25/
      CHARACTER ARGS
      CHARACTER OUTP*20
 222  FORMAT(I20)
 223  FORMAT(A)
      IBSKT  =  0
      NGRPS  =  0
      IP1  =  1
      IP2  = -1 
      I      =  1
      J      =  1
      ICSMIN =  HUGE(1)
      NARGS  =  IARGC()

      IF(NARGS == 0) THEN
         WRITE(*,223) "0"
         STOP 
      END IF

      DO II=1, NARGS
         CALL GETARG(II, ARGS)
         READ(ARGS, 222) JJ
         IBSKT(JJ) = IBSKT(JJ) + 1
      END DO

 10   CONTINUE 

      DO II=1,5
         IF (IBSKT(II) > 0) THEN
            GOTO 11
         END IF
      END DO

      ICST1 = 0
      DO M=1,NGRPS
         NACCUM = 0
         DO L=1,5
            NACCUM = NACCUM + IGRPS(L+(M-1)*5)
         END DO
         ICST1 = ICST1 + NACCUM * ICST * (100 - IDSCNT(NACCUM))
      END DO 
      IF (ICST1 < ICSMIN) THEN
         ICSMIN = ICST1
      END IF
      GOTO 40

 11   DO WHILE (.TRUE.)
         IF (IBSKT(I)>0) THEN
            DO WHILE(.TRUE.)
               IF (J>NGRPS) THEN
                  EXIT
               END IF 

               IF (IGRPS(I + 5 * (J-1) ) == 0) THEN
                  ISTCK(IP1:IP1+4) = (/1, I, J, NGRPS, IP2 /)
                  IP2 = IP1
                  IP1 = IP1 + 5 
                  IGRPS(I + 5 * ( J-1 )) = 1
                  IBSKT(I) = IBSKT(I) - 1
                  GOTO 10
 21               CONTINUE
               END IF
               J = J + 1 
            END DO 

            ISTCK(IP1:IP1+4) = (/2, I, J, NGRPS, IP2 /)
            IP2 = IP1
            IP1 = IP1 + 5 
            DO II=1,5
               IGRPS(II + NGRPS * 5) = 0
            END DO
            IGRPS(I + NGRPS * 5) = 1
            NGRPS = NGRPS + 1
            IBSKT(I) = IBSKT(I) - 1

            GOTO 10
 22         CONTINUE
         END IF 

         J = 1
         I = I + 1

         IF (I>5) THEN
            GOTO 40
         END IF
      END DO 


 40   CONTINUE
      IF (IP2<0) THEN
         GOTO 50 
      ELSE
         ICMFRM =  ISTCK(IP2)
         I =       ISTCK(IP2+1)
         J =       ISTCK(IP2+2)
         NGRPS =   ISTCK(IP2+3)
         IP2 =     ISTCK(IP2+4)
         IBSKT(I) = IBSKT(I) + 1
         IF (ICMFRM == 1) THEN
            IGRPS(I + 5 * (J-1)) = 0
         END IF 
         GOTO (21, 22), ICMFRM
      END IF 


 50   CONTINUE

      WRITE(OUTP,222) ICSMIN/100
      DO I=1,20
         IF (.NOT. OUTP(I:I) == " ") THEN
            WRITE(*,223) OUTP(I:20)
            STOP
         END IF 
      END DO
		END


More information about the Snark mailing list