annotate ext/clapack/src/s_cat.c @ 464:0076c66d2932

Credit daschuer
author Chris Cannam <cannam@all-day-breakfast.com>
date Wed, 29 May 2019 13:55:07 +0100
parents 905e45637745
children
rev   line source
c@427 1 /* Unless compiled with -DNO_OVERWRITE, this variant of s_cat allows the
c@427 2 * target of a concatenation to appear on its right-hand side (contrary
c@427 3 * to the Fortran 77 Standard, but in accordance with Fortran 90).
c@427 4 */
c@427 5
c@427 6 #include "f2c.h"
c@427 7 #ifndef NO_OVERWRITE
c@427 8 #include "stdio.h"
c@427 9 #undef abs
c@427 10 #ifdef KR_headers
c@427 11 extern char *F77_aloc();
c@427 12 extern void free();
c@427 13 extern void exit_();
c@427 14 #else
c@427 15 #undef min
c@427 16 #undef max
c@427 17 #include "stdlib.h"
c@427 18 extern
c@427 19 #ifdef __cplusplus
c@427 20 "C"
c@427 21 #endif
c@427 22 char *F77_aloc(ftnlen, const char*);
c@427 23 #endif
c@427 24 #include "string.h"
c@427 25 #endif /* NO_OVERWRITE */
c@427 26
c@427 27 #ifdef __cplusplus
c@427 28 extern "C" {
c@427 29 #endif
c@427 30
c@427 31 VOID
c@427 32 #ifdef KR_headers
c@427 33 s_cat(lp, rpp, rnp, np, ll) char *lp, *rpp[]; ftnint rnp[], *np; ftnlen ll;
c@427 34 #else
c@427 35 s_cat(char *lp, char *rpp[], ftnint rnp[], ftnint *np, ftnlen ll)
c@427 36 #endif
c@427 37 {
c@427 38 ftnlen i, nc;
c@427 39 char *rp;
c@427 40 ftnlen n = *np;
c@427 41 #ifndef NO_OVERWRITE
c@427 42 ftnlen L, m;
c@427 43 char *lp0, *lp1;
c@427 44
c@427 45 lp0 = 0;
c@427 46 lp1 = lp;
c@427 47 L = ll;
c@427 48 i = 0;
c@427 49 while(i < n) {
c@427 50 rp = rpp[i];
c@427 51 m = rnp[i++];
c@427 52 if (rp >= lp1 || rp + m <= lp) {
c@427 53 if ((L -= m) <= 0) {
c@427 54 n = i;
c@427 55 break;
c@427 56 }
c@427 57 lp1 += m;
c@427 58 continue;
c@427 59 }
c@427 60 lp0 = lp;
c@427 61 lp = lp1 = F77_aloc(L = ll, "s_cat");
c@427 62 break;
c@427 63 }
c@427 64 lp1 = lp;
c@427 65 #endif /* NO_OVERWRITE */
c@427 66 for(i = 0 ; i < n ; ++i) {
c@427 67 nc = ll;
c@427 68 if(rnp[i] < nc)
c@427 69 nc = rnp[i];
c@427 70 ll -= nc;
c@427 71 rp = rpp[i];
c@427 72 while(--nc >= 0)
c@427 73 *lp++ = *rp++;
c@427 74 }
c@427 75 while(--ll >= 0)
c@427 76 *lp++ = ' ';
c@427 77 #ifndef NO_OVERWRITE
c@427 78 if (lp0) {
c@427 79 memcpy(lp0, lp1, L);
c@427 80 free(lp1);
c@427 81 }
c@427 82 #endif
c@427 83 }
c@427 84 #ifdef __cplusplus
c@427 85 }
c@427 86 #endif